diff --git a/NAMESPACE b/NAMESPACE index 2506823a..c5afccfa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,8 +31,6 @@ export(cohortMethodCovariateBalanceServer) export(cohortMethodCovariateBalanceViewer) export(cohortMethodDiagnosticsSummaryServer) export(cohortMethodDiagnosticsSummaryViewer) -export(cohortMethodForestPlotServer) -export(cohortMethodForestPlotViewer) export(cohortMethodHelperFile) export(cohortMethodKaplanMeierServer) export(cohortMethodKaplanMeierViewer) @@ -44,11 +42,9 @@ export(cohortMethodPropensityModelServer) export(cohortMethodPropensityModelViewer) export(cohortMethodPropensityScoreDistServer) export(cohortMethodPropensityScoreDistViewer) -export(cohortMethodResultsTableServer) -export(cohortMethodResultsTableViewer) +export(cohortMethodResultSummaryServer) +export(cohortMethodResultSummaryViewer) export(cohortMethodServer) -export(cohortMethodSubgroupsServer) -export(cohortMethodSubgroupsViewer) export(cohortMethodSystematicErrorServer) export(cohortMethodSystematicErrorViewer) export(cohortMethodViewer) diff --git a/R/cohort-method-attrition.R b/R/cohort-method-attrition.R index f2f71518..3112c019 100644 --- a/R/cohort-method-attrition.R +++ b/R/cohort-method-attrition.R @@ -26,7 +26,7 @@ #' @export cohortMethodAttritionViewer <- function(id) { ns <- shiny::NS(id) - + shiny::div( shiny::plotOutput(outputId = ns("attritionPlot"), width = 600, height = 600), shiny::uiOutput(outputId = ns("attritionPlotCaption")), @@ -42,7 +42,6 @@ cohortMethodAttritionViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @@ -53,45 +52,40 @@ cohortMethodAttritionViewer <- function(id) { cohortMethodAttritionServer <- function( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) { - + shiny::moduleServer( id, function(input, output, session) { - - attritionPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - attrition <- getCohortMethodAttrition( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, - databaseId = row$databaseId, - analysisId = row$analysisId - ) + attritionPlot <- shiny::reactive({ + attrition <- getCohortMethodAttrition( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow + ) + if(!is.null(attrition)){ plot <- drawCohortMethodAttritionDiagram(attrition) return(plot) - } - }) - - output$attritionPlot <- shiny::renderPlot({ - return(attritionPlot()) + } else{ + return(NULL) + } }) - + + output$attritionPlot <- shiny::renderPlot({ + return(attritionPlot()) + }) + + output$downloadAttritionPlotPng <- shiny::downloadHandler(filename = "Attrition.png", contentType = "image/png", content = function(file) { ggplot2::ggsave(file, plot = attritionPlot(), width = 6, height = 7, dpi = 400) }) + output$downloadAttritionPlotPdf <- shiny::downloadHandler(filename = "Attrition.pdf", contentType = "application/pdf", content = function(file) { @@ -99,16 +93,203 @@ cohortMethodAttritionServer <- function( }) output$attritionPlotCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { + if (is.null(selectedRow()$target)) { return(NULL) } else { text <- "Figure 1. Attrition diagram, showing the Number of subjects in the target (%s) and comparator (%s) group after various stages in the analysis." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, selectedRow()$target, selectedRow()$comparator))) } }) } ) } + + +getCohortMethodAttrition <- function( + connectionHandler, + resultDatabaseSettings, + selectedRow +) { + + if(is.null(selectedRow()$targetId)){ + return(NULL) + } + + sql <- " + SELECT cmat.* + FROM + @schema.@cm_table_prefixattrition cmat + WHERE + cmat.target_id = @target_id + AND cmat.comparator_id = @comparator_id + AND cmat.outcome_id = @outcome_id + AND cmat.analysis_id = @analysis_id + AND cmat.database_id = '@database_id'; + " + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + #database_table = resultDatabaseSettings$databaseTable, + target_id = selectedRow()$targetId, + comparator_id = selectedRow()$comparatorId, + outcome_id = selectedRow()$outcomeId, + analysis_id = selectedRow()$analysisId, + database_id = selectedRow()$databaseId + ) + targetAttrition <- result[result$exposureId == selectedRow()$targetId, ] + comparatorAttrition <- result[result$exposureId == selectedRow()$comparatorId, ] + colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons" + targetAttrition$exposureId <- NULL + colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons" + comparatorAttrition$exposureId <- NULL + result <- merge(targetAttrition, comparatorAttrition) + result <- result[order(result$sequenceNumber), ] + + return(result) +} + + + + +drawCohortMethodAttritionDiagram <- function( + attrition, + targetLabel = "Target", + comparatorLabel = "Comparator" +) { + addStep <- function(data, attrition, row) { + label <- paste(strwrap(as.character(attrition$description[row]), width = 30), collapse = "\n") + data$leftBoxText[length(data$leftBoxText) + 1] <- label + data$rightBoxText[length(data$rightBoxText) + 1] <- paste(targetLabel, + ": n = ", + data$currentTarget - attrition$targetPersons[row], + "\n", + comparatorLabel, + ": n = ", + data$currentComparator - attrition$comparatorPersons[row], + sep = "") + data$currentTarget <- attrition$targetPersons[row] + data$currentComparator <- attrition$comparatorPersons[row] + return(data) + } + data <- list(leftBoxText = c(paste("Exposed:\n", + targetLabel, + ": n = ", + attrition$targetPersons[1], + "\n", + comparatorLabel, + ": n = ", + attrition$comparatorPersons[1], + sep = "")), rightBoxText = c(""), currentTarget = attrition$targetPersons[1], currentComparator = attrition$comparatorPersons[1]) + for (i in 2:nrow(attrition)) { + data <- addStep(data, attrition, i) + } + + + data$leftBoxText[length(data$leftBoxText) + 1] <- paste("Study population:\n", + targetLabel, + ": n = ", + data$currentTarget, + "\n", + comparatorLabel, + ": n = ", + data$currentComparator, + sep = "") + leftBoxText <- data$leftBoxText + rightBoxText <- data$rightBoxText + nSteps <- length(leftBoxText) + + boxHeight <- (1/nSteps) - 0.03 + boxWidth <- 0.45 + shadowOffset <- 0.01 + arrowLength <- 0.01 + x <- function(x) { + return(0.25 + ((x - 1)/2)) + } + y <- function(y) { + return(1 - (y - 0.5) * (1/nSteps)) + } + + downArrow <- function(p, x1, y1, x2, y2) { + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 + arrowLength, + yend = y2 + arrowLength)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 + arrowLength)) + return(p) + } + rightArrow <- function(p, x1, y1, x2, y2) { + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 + arrowLength)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 - arrowLength)) + return(p) + } + box <- function(p, x, y) { + p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2) + shadowOffset, + ymin = y - (boxHeight/2) - shadowOffset, + xmax = x + (boxWidth/2) + shadowOffset, + ymax = y + (boxHeight/2) - shadowOffset), fill = grDevices::rgb(0, + 0, + 0, + alpha = 0.2)) + p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2), + ymin = y - (boxHeight/2), + xmax = x + (boxWidth/2), + ymax = y + (boxHeight/2)), fill = grDevices::rgb(0.94, + 0.94, + 0.94), color = "black") + return(p) + } + label <- function(p, x, y, text, hjust = 0) { + p <- p + ggplot2::geom_text(ggplot2::aes_string(x = x, y = y, label = paste("\"", substring(text,1,40), "\"", + sep = "")), + hjust = hjust, + size = 3.7) + return(p) + } + + p <- ggplot2::ggplot() + for (i in 2:nSteps - 1) { + p <- downArrow(p, x(1), y(i) - (boxHeight/2), x(1), y(i + 1) + (boxHeight/2)) + p <- label(p, x(1) + 0.02, y(i + 0.5), "Y") + } + for (i in 2:(nSteps - 1)) { + p <- rightArrow(p, x(1) + boxWidth/2, y(i), x(2) - boxWidth/2, y(i)) + p <- label(p, x(1.5), y(i) - 0.02, "N", 0.5) + } + for (i in 1:nSteps) { + p <- box(p, x(1), y(i)) + } + for (i in 2:(nSteps - 1)) { + p <- box(p, x(2), y(i)) + } + for (i in 1:nSteps) { + p <- label(p, x(1) - boxWidth/2 + 0.02, y(i), text = leftBoxText[i]) + } + for (i in 2:(nSteps - 1)) { + p <- label(p, x(2) - boxWidth/2 + 0.02, y(i), text = rightBoxText[i]) + } + p <- p + ggplot2::theme(legend.position = "none", + plot.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.text = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank()) + + return(p) +} diff --git a/R/cohort-method-covariateBalance.R b/R/cohort-method-covariateBalance.R index 808c25d0..1ecdfccf 100644 --- a/R/cohort-method-covariateBalance.R +++ b/R/cohort-method-covariateBalance.R @@ -30,33 +30,21 @@ cohortMethodCovariateBalanceViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - shiny::conditionalPanel(condition = "output.isMetaAnalysis == false", - ns = ns, - shiny::uiOutput(outputId = ns("hoverInfoBalanceScatter")), - - plotly::plotlyOutput(ns("balancePlot")), - shiny::uiOutput(outputId = ns("balancePlotCaption")), - - shiny::downloadButton( - ns('downloadCovariateBalance'), - label = "Download" - ), - - shiny::textInput(ns("covariateHighlight"), "Highlight covariates containing:", ), - shiny::actionButton(ns("covariateHighlightButton"), "Highlight") - + shiny::uiOutput(outputId = ns("hoverInfoBalanceScatter")), + + plotly::plotlyOutput(ns("balancePlot")), + shiny::uiOutput(outputId = ns("balancePlotCaption")), + + shiny::downloadButton( + ns('downloadCovariateBalance'), + label = "Download" ), - shiny::conditionalPanel(condition = "output.isMetaAnalysis == true", - ns = ns, - shiny::plotOutput(outputId = ns("balanceSummaryPlot")), - shiny::uiOutput(outputId = ns("balanceSummaryPlotCaption")), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadBalanceSummaryPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadBalanceSummaryPlotPdf"), - label = "Download plot as PDF") - )) + + shiny::textInput(ns("covariateHighlight"), "Highlight covariates containing:", ), + shiny::actionButton(ns("covariateHighlightButton"), "Highlight") + ) + } @@ -64,7 +52,6 @@ cohortMethodCovariateBalanceViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds @@ -76,7 +63,6 @@ cohortMethodCovariateBalanceViewer <- function(id) { cohortMethodCovariateBalanceServer <- function( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings, metaAnalysisDbIds = NULL) { @@ -88,12 +74,15 @@ cohortMethodCovariateBalanceServer <- function( balance <- shiny::reactive({ row <- selectedRow() + if(is.null(row$targetId)){ + return(NULL) + } balance <- tryCatch({ getCohortMethodCovariateBalanceShared( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + targetId = row$targetId, + comparatorId = row$comparatorId, databaseId = row$databaseId, analysisId = row$analysisId)}, error = function(e){return(NULL)} @@ -101,16 +90,7 @@ cohortMethodCovariateBalanceServer <- function( return(balance) }) - output$isMetaAnalysis <- shiny::reactive({ - return(FALSE) - ##TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - + textSearchCohortMethod <- shiny::reactiveVal(NULL) shiny::observeEvent( @@ -206,8 +186,8 @@ cohortMethodCovariateBalanceServer <- function( balanceSummary <- getCohortMethodCovariateBalanceSummary( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + targetId = row$targetId, + comparatorId = row$comparatorId, analysisId = row$analysisId, databaseId = row$analysisId, beforeLabel = paste("Before", row$psStrategy), @@ -357,7 +337,7 @@ plotCohortMethodCovariateBalanceScatterPlotNew <- function( balance, beforeLabel = "Before propensity score adjustment", afterLabel = "After propensity score adjustment", - textsearch = NULL + textsearch = shiny::reactiveVal(NULL) ){ if(is.null(textsearch())){ @@ -406,3 +386,81 @@ plotCohortMethodCovariateBalanceScatterPlotNew <- function( return(plot) } + + + +plotCohortMethodCovariateBalanceSummary <- function(balanceSummary, + threshold = 0, + beforeLabel = "Before matching", + afterLabel = "After matching") { + balanceSummary <- balanceSummary[rev(order(balanceSummary$databaseId)), ] + dbs <- data.frame(databaseId = unique(balanceSummary$databaseId), + x = 1:length(unique(balanceSummary$databaseId))) + vizData <- merge(balanceSummary, dbs) + + vizData$type <- factor(vizData$type, levels = c(beforeLabel, afterLabel)) + + plot <- ggplot2::ggplot(vizData, ggplot2::aes(x = .data$x, + ymin = .data$ymin, + lower = .data$lower, + middle = .data$median, + upper = .data$upper, + ymax = .data$ymax, + group = .data$databaseId)) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) + + ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) + + ggplot2::scale_y_continuous("Standardized difference of mean") + + ggplot2::coord_flip() + + ggplot2::facet_grid(~type) + + ggplot2::theme(panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank(), + panel.grid.major.x = ggplot2::element_line(color = "#AAAAAA"), + panel.background = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.title.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(size = 11), + axis.title.x = ggplot2::element_text(size = 11), + axis.ticks.x = ggplot2::element_line(color = "#AAAAAA"), + strip.background = ggplot2::element_blank(), + strip.text = ggplot2::element_text(size = 11), + plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + + if (threshold != 0) { + plot <- plot + ggplot2::geom_hline(yintercept = c(threshold, -threshold), linetype = "dotted") + } + after <- vizData[vizData$type == afterLabel, ] + after$max <- pmax(abs(after$ymin), abs(after$ymax)) + text <- data.frame(y = rep(c(after$x, nrow(after) + 1.25) , 3), + x = rep(c(1,2,3), each = nrow(after) + 1), + label = c(c(as.character(after$databaseId), + "Source", + formatC(after$covariateCount, big.mark = ",", format = "d"), + "Covariate\ncount", + formatC(after$max, digits = 2, format = "f"), + paste(afterLabel, "max(absolute)", sep = "\n"))), + dummy = "") + + data_table <- ggplot2::ggplot(text, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + + ggplot2::geom_text(size = 4, hjust=0, vjust=0.5) + + ggplot2::geom_hline(ggplot2::aes(yintercept=nrow(after) + 0.5)) + + ggplot2::theme(panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + legend.position = "none", + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(colour="white"), + axis.text.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_line(colour="white"), + strip.background = ggplot2::element_blank(), + plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + + ggplot2::labs(x="",y="") + + ggplot2::facet_grid(~dummy) + + ggplot2::coord_cartesian(xlim=c(1,4), ylim = c(0.5, max(vizData$x) + 1.75)) + + plot <- gridExtra::grid.arrange(data_table, plot, ncol = 2) + return(plot) +} diff --git a/R/cohort-method-diagnosticsSummary.R b/R/cohort-method-diagnosticsSummary.R index fd2cdd05..a7fa38bc 100644 --- a/R/cohort-method-diagnosticsSummary.R +++ b/R/cohort-method-diagnosticsSummary.R @@ -30,11 +30,15 @@ cohortMethodDiagnosticsSummaryViewer <- function(id) { shiny::div( - inputSelectionViewer(ns("input-selection")), + #shiny::conditionalPanel( + # condition = 'input.generate != 0', + # ns = shiny::NS(ns("input-selection")), - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Cohort Method Diagnostics'), + solidHeader = TRUE, shiny::tabsetPanel( type = 'pills', @@ -58,6 +62,7 @@ cohortMethodDiagnosticsSummaryViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes +#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user #' #' @return #' the PLE diagnostics summary results @@ -66,133 +71,24 @@ cohortMethodDiagnosticsSummaryViewer <- function(id) { cohortMethodDiagnosticsSummaryServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + inputSelected ) { shiny::moduleServer( id, function(input, output, session) { - targetIds <- getCmDiagCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'target' - ) - outcomeIds <- getCmDiagCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'outcome' - ) - comparatorIds <- getCmDiagCohorts( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - type = 'comparator' - ) - analysisIds <- getCmDiagAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - inputSelected <- inputSelectionServer( - id = "input-selection", - inputSettingList = list( - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'targetIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Target: ', - choices = targetIds, - selected = targetIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 1, - columnWidth = 6, - varName = 'outcomeIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Outcome: ', - choices = outcomeIds, - selected = outcomeIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'comparatorIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Comparator: ', - choices = comparatorIds, - selected = comparatorIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'analysisIds', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Analysis: ', - choices = analysisIds, - selected = analysisIds[1], - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - ) - ) - data <- shiny::reactive({ getCmDiagnosticsData( connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetIds = inputSelected()$targetIds, - outcomeIds = inputSelected()$outcomeIds, - comparatorIds = inputSelected()$comparatorIds, - analysisIds = inputSelected()$analysisIds + inputSelected = inputSelected ) }) data2 <- shiny::reactive({ - diagnosticSummaryFormat(data) + diagnosticSummaryFormat(data) }) customColDefs <- list( @@ -206,13 +102,15 @@ cohortMethodDiagnosticsSummaryServer <- function( header = withTooltip( "Target", "The target cohort of interest " - ) + ), + minWidth = 300 ), comparator = reactable::colDef( header = withTooltip( "Comparator", "The comparator cohort of interest " - ) + ), + minWidth = 300 ), outcome = reactable::colDef( header = withTooltip( @@ -231,23 +129,47 @@ cohortMethodDiagnosticsSummaryServer <- function( header = withTooltip( "mdrr", "The minimum detectible relative risk" - ) + ), + format = reactable::colFormat(digits = 4) ), ease = reactable::colDef( header = withTooltip( "ease", "The ..." - ) + ), + format = reactable::colFormat(digits = 4) ), - timeTrendP = reactable::colDef( + maxSdm = reactable::colDef( header = withTooltip( - "timeTrendP", + "max SDM", "The ..." - ) + ), + format = reactable::colFormat(digits = 4) + ), + sharedMaxSdm = reactable::colDef( + header = withTooltip( + "shared max SDM", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + equipoise = reactable::colDef( + header = withTooltip( + "equipoise", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + attritionFraction = reactable::colDef( + header = withTooltip( + "Attrition fraction", + "The ..." + ), + format = reactable::colFormat(digits = 4) ), - preExposureP = reactable::colDef( + balanceDiagnostic = reactable::colDef( header = withTooltip( - "preExposureP", + "balanceDiagnostic", "The ..." ) ), @@ -263,15 +185,15 @@ cohortMethodDiagnosticsSummaryServer <- function( "The ..." ) ), - timeTrendDiagnostic = reactable::colDef( + attritionDiagnostic = reactable::colDef( header = withTooltip( - "timeTrendDiagnostic", + "attritionDiagnostic", "The ..." ) ), - preExposureDiagnostic = reactable::colDef( + equipoiseDiagnostic = reactable::colDef( header = withTooltip( - "preExposureDiagnostic", + "equipoiseDiagnostic", "The ..." ) ), @@ -281,7 +203,9 @@ cohortMethodDiagnosticsSummaryServer <- function( "unblind", "If the value is 1 then the diagnostics passed and results can be unblinded" ) - ) + ), + + summaryValue = reactable::colDef(show = F) ) @@ -291,7 +215,25 @@ cohortMethodDiagnosticsSummaryServer <- function( colDefsInput = customColDefs ) - customColDefs2 <- list( + resultTableServer( + id = "diagnosticsSummaryTable", + df = data2, + colDefsInput = getColDefsCmDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + ) + + } + ) +} + +getColDefsCmDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( databaseName = reactable::colDef( header = withTooltip( "Database", @@ -314,25 +256,18 @@ cohortMethodDiagnosticsSummaryServer <- function( sticky = "left" ) ) - - resultTableServer( - id = "diagnosticsSummaryTable", - df = data2, - colDefsInput = styleColumns(customColDefs2, outcomeIds, analysisIds) - ) - - - } - ) -} - -styleColumns <- function( - customColDefs, - outcomeIds, - analysisIds -){ + + outcomes <- getCmCohorts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'outcome' + ) + analyses <- getCmAnalyses( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) - colnameFormat <- merge(names(outcomeIds), names(analysisIds)) + colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) styleList <- lapply( @@ -358,7 +293,7 @@ styleColumns <- function( } ) names(styleList) <- colnameFormat - result <- append(customColDefs, styleList) + result <- append(fixedColumns, styleList) return(result) } @@ -369,6 +304,10 @@ diagnosticSummaryFormat <- function( namesFrom = c('outcome','analysis') ){ + if(is.null(data())){ + return(NULL) + } + data2 <- tidyr::pivot_wider( data = data(), id_cols = idCols, @@ -379,80 +318,23 @@ diagnosticSummaryFormat <- function( return(data2) } -getCmDiagCohorts <- function( - connectionHandler, - resultDatabaseSettings, - type = 'target' -){ - - sql <- " - SELECT DISTINCT - cgcd1.cohort_name as names, - cgcd1.cohort_definition_id - FROM - @schema.@cm_table_prefixdiagnostics_summary cmds - INNER JOIN - @schema.@cg_table_prefixcohort_definition cgcd1 - ON cmds.@type_id = cgcd1.cohort_definition_id; - " - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - type = type - ) - - res <- result$cohortDefinitionId - names(res) <- result$names - - return( - res - ) -} - -getCmDiagAnalyses <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- " - SELECT DISTINCT - cma.analysis_id, - cma.description as names - FROM - @schema.@cm_table_prefixdiagnostics_summary cmds - INNER JOIN - @schema.@cm_table_prefixanalysis cma - ON cmds.analysis_id = cma.analysis_id - ; - " - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix - ) - - res <- result$analysisId - names(res) <- result$names - - return( - res - ) - -} getCmDiagnosticsData <- function( connectionHandler, resultDatabaseSettings, - targetIds, - outcomeIds, - comparatorIds = NULL, - analysisIds = NULL + inputSelected ) { + + targetIds = inputSelected()$targetIds + outcomeIds = inputSelected()$outcomeIds + comparatorIds = inputSelected()$comparatorIds + analysisIds = inputSelected()$analysisIds + + if(is.null(targetIds) || is.null(outcomeIds)){ + return(NULL) + } + sql <- " SELECT DISTINCT dmd.cdm_source_abbreviation database_name, diff --git a/R/cohort-method-forestPlot.R b/R/cohort-method-forestPlot.R deleted file mode 100644 index 1caa5172..00000000 --- a/R/cohort-method-forestPlot.R +++ /dev/null @@ -1,114 +0,0 @@ -# @file cohort-method-forestPlot -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. - -#' The module viewer for rendering the PLE results forest plot -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort method forest plot -#' -#' @export -cohortMethodForestPlotViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::plotOutput(outputId = ns("forestPlot")), - shiny::uiOutput(outputId = ns("forestPlotCaption")), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadForestPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadForestPlotPdf"), - label = "Download plot as PDF")) - ) -} - - - - - -#' The module server for rendering the PLE multiple results forest plot -#' -#' @param id the unique reference id for the module -#' @param connectionHandler connection -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param metaAnalysisDbIds metaAnalysisDbIds -#' @param resultDatabaseSettings a list containing the result schema and prefixes -#' -#' @return -#' the PLE forest plot content server -#' -#' @export -cohortMethodForestPlotServer <- function( - id, connectionHandler, selectedRow, inputParams, metaAnalysisDbIds = NULL, - resultDatabaseSettings - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - forestPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row) || !(row$databaseId %in% metaAnalysisDbIds)) { - return(NULL) - } else { - results <- getCohortMethodMainResults( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetIds = row$targetId, - comparatorIds = row$comparatorId, - outcomeIds = row$outcomeId, - analysisIds = row$analysisId - ) - plot <- plotCohortMethodForest(results) - return(plot) - } - }) - - output$forestPlot <- shiny::renderPlot({ - forestPlot() - }) - - output$forestPlotCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - text <- "Figure 6. Forest plot showing the per-database and summary hazard ratios (and 95 percent confidence - intervals) comparing %s to %s for the outcome of %s, using %s. Estimates are shown both before and after empirical - calibration. The I2 is computed on the uncalibrated estimates." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator, inputParams()$outcome, row$psStrategy))) - } - }) - - output$downloadForestPlotPng <- shiny::downloadHandler(filename = "ForestPlot.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = forestPlot(), width = 12, height = 9, dpi = 400) - }) - - output$downloadForestPlotPdf <- shiny::downloadHandler(filename = "ForestPlot.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = forestPlot(), width = 12, height = 9) - }) - - } - ) -} diff --git a/R/cohort-method-full-result.R b/R/cohort-method-full-result.R new file mode 100644 index 00000000..7f4e5010 --- /dev/null +++ b/R/cohort-method-full-result.R @@ -0,0 +1,180 @@ +cohortMethodFullResultViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Explorer'), + solidHeader = TRUE, + + # add selected settings + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected: ', + collapsible = T, + shiny::uiOutput(ns('selection')) + ), + + shiny::tabsetPanel( + id = ns("fullTabsetPanel"), + type = 'pills', + shiny::tabPanel( + title = "Power", + cohortMethodPowerViewer(ns("power")) + ), + shiny::tabPanel( + title = "Attrition", + cohortMethodAttritionViewer(ns("attrition")) + ), + shiny::tabPanel( + title = "Population characteristics", + cohortMethodPopulationCharacteristicsViewer(ns("popCharacteristics")) + ), + shiny::tabPanel( + title = "Propensity model", + cohortMethodPropensityModelViewer(ns("propensityModel")) + ), + shiny::tabPanel( + title = "Propensity scores", + cohortMethodPropensityScoreDistViewer(ns("propensityScoreDist")) + ), + shiny::tabPanel( + title = "Covariate balance", + cohortMethodCovariateBalanceViewer(ns("covariateBalance")) + ), + shiny::tabPanel( + title = "Systematic error", + cohortMethodSystematicErrorViewer(ns("systematicError")) + ), + shiny::tabPanel( + title = "Kaplan-Meier", + cohortMethodKaplanMeierViewer(ns("kaplanMeier")) + ) + ) + ) + +} + +cohortMethodFullResultServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + selectedRow +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + output$selection <- shiny::renderUI({ + otext <- list() + otext[[1]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Target: '), + selectedRow()$target + ), + shiny::column( + width = 6, + shiny::tags$b('Comparator: '), + selectedRow()$comparator + ) + ) + otext[[2]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Outcome: '), + selectedRow()$outcome + ), + shiny::column( + width = 6, + shiny::tags$b('Analysis: '), + selectedRow()$description + ) + ) + otext[[3]] <- shiny::fluidRow( + shiny::column( + width = 3, + shiny::tags$b('Database: '), + selectedRow()$cdmSourceAbbreviation + ), + shiny::column( + width = 6, + shiny::tags$b('') + ) + ) + shiny::div(otext) + }) + + shiny::observeEvent(selectedRow(),{ + if(!is.null(selectedRow()$unblind)){ + if (selectedRow()$unblind == 1) { + shiny::showTab("fullTabsetPanel", "Kaplan-Meier", session = session) + } else{ + shiny::hideTab("fullTabsetPanel", "Kaplan-Meier", session = session) + } + } + }) + + # selected row: : - reactive list with: psStrategy + + cohortMethodPowerServer( + id = "power", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodAttritionServer( + id = "attrition", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPopulationCharacteristicsServer( + id = "popCharacteristics", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPropensityModelServer( + id = "propensityModel", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPropensityScoreDistServer( + id = "propensityScoreDist", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodCovariateBalanceServer( + id = "covariateBalance", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodSystematicErrorServer( + id = "systematicError", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodKaplanMeierServer( + id = "kaplanMeier", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + } + ) +} \ No newline at end of file diff --git a/R/cohort-method-kaplainMeier.R b/R/cohort-method-kaplainMeier.R index 8474f9c8..6eb75396 100644 --- a/R/cohort-method-kaplainMeier.R +++ b/R/cohort-method-kaplainMeier.R @@ -43,10 +43,8 @@ cohortMethodKaplanMeierViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' @param metaAnalysisDbIds metaAnalysisDbIds #' #' @return #' the PLE Kaplain Meier content server @@ -55,26 +53,15 @@ cohortMethodKaplanMeierViewer <- function(id) { cohortMethodKaplanMeierServer <- function( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) { shiny::moduleServer( id, function(input, output, session) { - output$isMetaAnalysis <- shiny::reactive({ - #TODO: update once MA implemented - return(FALSE) - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - + kaplanMeierPlot <- shiny::reactive({ row <- selectedRow() if (is.null(row)) { @@ -83,9 +70,9 @@ cohortMethodKaplanMeierServer <- function( km <- getCohortMethodKaplanMeier( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -95,21 +82,13 @@ cohortMethodKaplanMeierServer <- function( km$targetAtRisk[removeInd] <- NA km$comparatorAtRisk[removeInd] <- NA - targetName <- getCohortNameFromId( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - cohortId = inputParams()$target - ) - comparatorName <- getCohortNameFromId( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - cohortId = inputParams()$comparator - ) + targetName <- row$target + comparatorName <- row$comparator plot <- plotCohortMethodKaplanMeier( kaplanMeier = km, - targetName = targetName$cohortName, - comparatorName = comparatorName$cohortName + targetName = targetName, + comparatorName = comparatorName ) return(plot) } @@ -141,7 +120,7 @@ cohortMethodKaplanMeierServer <- function( comparator curve (%s) applies reweighting to approximate the counterfactual of what the target survival would look like had the target cohort been exposed to the comparator instead. The shaded area denotes the 95 percent confidence interval." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } }) @@ -152,6 +131,43 @@ cohortMethodKaplanMeierServer <- function( +getCohortMethodKaplanMeier <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + outcomeId, + databaseId, + analysisId +) { + + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixkaplan_meier_dist cmkmd + WHERE + cmkmd.target_id = @target_id + AND cmkmd.comparator_id = @comparator_id + AND cmkmd.outcome_id = @outcome_id + AND cmkmd.analysis_id = @analysis_id + AND cmkmd.database_id = '@database_id'; + " + + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + #database_table = resultDatabaseSettings$databaseTable, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + analysis_id = analysisId, + database_id = databaseId + ) + ) +} # CohortMethod-kaplainMeier @@ -167,14 +183,14 @@ plotCohortMethodKaplanMeier <- function( s = kaplanMeier$targetSurvival, lower = kaplanMeier$targetSurvivalLb, upper = kaplanMeier$targetSurvivalUb, - strata = paste0(" ", targetName, " ") + strata = ' Target' #paste0(" ", targetName, " ") ), data.frame( time = kaplanMeier$time, s = kaplanMeier$comparatorSurvival, lower = kaplanMeier$comparatorSurvivalLb, upper = kaplanMeier$comparatorSurvivalUb, - strata = paste0(" ", comparatorName) + strata = ' Comparator'#paste0(" ", comparatorName) ) ) @@ -225,8 +241,8 @@ plotCohortMethodKaplanMeier <- function( x = c(0, xBreaks, xBreaks), y = as.factor( c("Number at risk", - rep(targetName, length(xBreaks)), - rep(comparatorName, length(xBreaks)) + rep('Target', length(xBreaks)), + rep('Comparator', length(xBreaks)) ) ), label = c( @@ -235,7 +251,7 @@ plotCohortMethodKaplanMeier <- function( formatC(comparatorAtRisk, big.mark = ",", mode = "integer") ) ) - labels$y <- factor(labels$y, levels = c(comparatorName, targetName, "Number at risk")) + labels$y <- factor(labels$y, levels = c('Comparator','Target', "Number at risk")) dataTable <- ggplot2::ggplot( data = labels, diff --git a/R/cohort-method-main.R b/R/cohort-method-main.R index 5ba555db..c555d062 100644 --- a/R/cohort-method-main.R +++ b/R/cohort-method-main.R @@ -48,96 +48,32 @@ cohortMethodViewer <- function(id) { title = shiny::span( shiny::icon("chart-column"), 'Cohort Method'), solidHeader = TRUE, - #shiny::fluidPage(style = "width:1500px;", - shinydashboard::box( - collapsible = TRUE, - collapsed = TRUE, - title = "Cohort Method Evidence Explorer", - width = "100%"#, - #shiny::htmlTemplate(system.file("cohort-diagnostics-www", "cohortCounts.html", package = utils::packageName())) - ), - - htmltools::tags$head(htmltools::tags$style(type = "text/css", " - #loadmessage { - position: fixed; - top: 0px; - left: 0px; - width: 100%; - padding: 5px 0px 5px 0px; - text-align: center; - font-weight: bold; - font-size: 100%; - color: #000000; - background-color: #ADD8E6; - z-index: 105; - } - ")), - shiny::conditionalPanel(id = ns("loadmessage"), - condition = "$('html').hasClass('shiny-busy')", - htmltools::tags$div("Processing...")), - shiny::tabsetPanel( - type = 'pills', - id = ns("mainTabsetPanel"), - shiny::tabPanel( - title = "Diagnostics", - cohortMethodDiagnosticsSummaryViewer(ns("estimationDiganostics")) - ), - shiny::tabPanel( - title = "Results", - shiny::fluidRow( - shiny::column(width = 3, - shiny::uiOutput(outputId = ns("targetWidget")), - shiny::uiOutput(outputId = ns("comparatorWidget")), - shiny::uiOutput(outputId = ns("outcomeWidget")), - shiny::uiOutput(outputId = ns("databaseWidget")), - shiny::uiOutput(outputId = ns("analysisWidget")) - ), - shiny::column(width = 9, - cohortMethodResultsTableViewer(ns("resultsTable")), - shiny::conditionalPanel("output.rowIsSelected == true", ns = ns, - shiny::tabsetPanel(id = ns("detailsTabsetPanel"), - shiny::tabPanel(title = "Power", - cohortMethodPowerViewer(ns("power")) - ), - shiny::tabPanel(title = "Attrition", - cohortMethodAttritionViewer(ns("attrition")) - ), - shiny::tabPanel(title = "Population characteristics", - cohortMethodPopulationCharacteristicsViewer(ns("popCharacteristics")) - ), - shiny::tabPanel(title = "Propensity model", - cohortMethodPropensityModelViewer(ns("propensityModel")) - ), - shiny::tabPanel(title = "Propensity scores", - cohortMethodPropensityScoreDistViewer(ns("propensityScoreDist")) - ), - shiny::tabPanel(title = "Covariate balance", - cohortMethodCovariateBalanceViewer(ns("covariateBalance")) - ), - shiny::tabPanel(title = "Systematic error", - cohortMethodSystematicErrorViewer(ns("systematicError")) - ), - shiny::tabPanel(title = "Forest plot", - cohortMethodForestPlotViewer(ns("forestPlot")) - ), - shiny::tabPanel(title = "Kaplan-Meier", - cohortMethodKaplanMeierViewer(ns("kaplanMeier")) - ), - shiny::tabPanel(title = "Subgroups", - cohortMethodSubgroupsViewer(ns("subgroups")) - ) - - ) # end tabsetPanel - ) # end conditionalPanel - ) - - ) - ) - ) + # Input selection of T, C and Os + inputSelectionViewer(ns("input-selection")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection")), + + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel'), + + shiny::tabPanel( + title = "Diagnostics", + cohortMethodDiagnosticsSummaryViewer(ns("cmDiganostics")) + ), + + shiny::tabPanel( + title = "Results", + cohortMethodResultSummaryViewer(ns("cmResults")) + ) + ) + ) + ) - } - + #' The module server for the main cohort method module #' @@ -161,203 +97,192 @@ cohortMethodServer <- function( dataFolder <- NULL - output$targetWidget <- shiny::renderUI({ - targets <- getCohortMethodTargetChoices( - connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - shiny::selectInput(inputId = session$ns("target"), - label = "Target", - choices = getCohortMethodSelectNamedChoices(targets$targetId, - targets$cohortName)) - }) - - output$comparatorWidget <- shiny::renderUI({ - comparators <- getCohortMethodComparatorChoices( - connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - shiny::selectInput(inputId = session$ns("comparator"), - label = "Comparator", - choices = getCohortMethodSelectNamedChoices(comparators$comparatorId, - comparators$cohortName)) - }) - - output$outcomeWidget <- shiny::renderUI({ - outcomes <- getCohortMethodOutcomeChoices( - connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - shiny::selectInput(inputId = session$ns("outcome"), - label = "Outcome", - choices = getCohortMethodSelectNamedChoices(outcomes$outcomeId, - outcomes$cohortName)) - }) - output$databaseWidget<- shiny::renderUI({ - databases <- getCohortMethodDatabaseChoices( - connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - shiny::checkboxGroupInput(inputId = session$ns("database"), - label = "Data source", - choices = getCohortMethodSelectNamedChoices(databases$databaseId, - databases$cdmSourceAbbreviation), - selected = unique(databases$databaseId)) - }) - output$analysisWidget <- shiny::renderUI({ - analyses <- getCmAnalysisOptions( - connectionHandler, - resultDatabaseSettings - ) - shiny::checkboxGroupInput(inputId = session$ns("analysis"), - label = "Analysis", - choices = getCohortMethodSelectNamedChoices(analyses$analysisId, - analyses$description), - selected = unique(analyses$analysisId)) - }) - - - inputParams <- shiny::reactive({ - t <- list() - t$target <- input$target - t$comparator <- input$comparator - t$outcome <- input$outcome - t$analysis <- input$analysis - t$database <- input$database - return(t) - }) - - - cohortMethodDiagnosticsSummaryServer( - id = "estimationDiganostics", - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - - selectedRow <- cohortMethodResultsTableServer( - id = "resultsTable", - connectionHandler = connectionHandler, - inputParams = inputParams, - resultDatabaseSettings = resultDatabaseSettings - ) - - output$rowIsSelected <- shiny::reactive({ - return(!is.null(selectedRow())) - }) - - - if (!exists("cmInteractionResult")) { # ISSUE: this should be an input resultDatabaseSettings$cmInteractionResult and not null check - #TODO: update for testing once subgroup analysis completed - shiny::hideTab(inputId = "detailsTabsetPanel", target = "Subgroups", - session = session) - } - - shiny::outputOptions(output, "rowIsSelected", suspendWhenHidden = FALSE) - - output$isMetaAnalysis <- shiny::reactive({ - #TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- FALSE # !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - if (!is.null(row)) { - if (isMetaAnalysis) { - shiny::hideTab("detailsTabsetPanel", "Attrition", session = session) - shiny::hideTab("detailsTabsetPanel", "Population characteristics", session = session) - shiny::hideTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - shiny::hideTab("detailsTabsetPanel", "Propensity model", session = session) - shiny::showTab("detailsTabsetPanel", "Forest plot", session = session) - } else { - shiny::showTab("detailsTabsetPanel", "Attrition", session = session) - shiny::showTab("detailsTabsetPanel", "Population characteristics", session = session) - if (row$unblind) { - shiny::showTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - } else{ - shiny::hideTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - } - shiny::showTab("detailsTabsetPanel", "Propensity model", session = session) - shiny::hideTab("detailsTabsetPanel", "Forest plot", session = session) - } - } - return(isMetaAnalysis) - }) - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - - - cohortMethodPowerServer( - id = "power", - selectedRow = selectedRow, - inputParams = inputParams, + targetIds <- getCmCohorts( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + type = 'target' ) - - cohortMethodAttritionServer( - id = "attrition", - selectedRow = selectedRow, - inputParams = inputParams, + outcomeIds <- getCmCohorts( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + type = 'outcome' ) - - cohortMethodPopulationCharacteristicsServer( - id = "popCharacteristics", - selectedRow = selectedRow, - inputParams = inputParams, + comparatorIds <- getCmCohorts( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + type = 'comparator' ) - - cohortMethodPropensityModelServer( - id = "propensityModel", - selectedRow = selectedRow, - inputParams = inputParams, + analysisIds <- getCmAnalyses( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) - cohortMethodPropensityScoreDistServer( - id = "propensityScoreDist", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + inputSelected <- inputSelectionServer( + id = "input-selection", + inputSettingList = list( + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'targetIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Target: ', + choices = targetIds, + selected = targetIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'outcomeIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Outcome: ', + choices = outcomeIds, + selected = outcomeIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + createInputSetting( + rowNumber = 2, + columnWidth = 6, + varName = 'comparatorIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Comparator: ', + choices = comparatorIds, + selected = comparatorIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + + createInputSetting( + rowNumber = 2, + columnWidth = 6, + varName = 'analysisIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Analysis: ', + choices = analysisIds, + selected = analysisIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ) ) - cohortMethodCovariateBalanceServer( - id = "covariateBalance", - selectedRow = selectedRow, - inputParams = inputParams, + cohortMethodDiagnosticsSummaryServer( + id = "cmDiganostics", connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) - cohortMethodSystematicErrorServer( - id = "systematicError", - selectedRow = selectedRow, - inputParams = inputParams, + cohortMethodResultSummaryServer( + id = "cmResults", connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - cohortMethodKaplanMeierServer( - id = "kaplanMeier", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - #TODO: complete once MA implemented - # estimationForestPlotServer("forestPlot", connection, selectedRow, inputParams) - - #TODO: revisit once subgroup example conducted - cohortMethodSubgroupsServer( - id = "subgroups", - selectedRow = selectedRow, - inputParams = inputParams + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected ) } ) } +getCmCohorts <- function( + connectionHandler, + resultDatabaseSettings, + type = 'target' +){ + + sql <- " + SELECT DISTINCT + cgcd1.cohort_name as names, + cgcd1.cohort_definition_id + FROM + @schema.@cm_table_prefixresult cmds + INNER JOIN + @schema.@cg_table_prefixcohort_definition cgcd1 + ON cmds.@type_id = cgcd1.cohort_definition_id; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + type = type + ) + + res <- result$cohortDefinitionId + names(res) <- result$names + + return( + res + ) +} + +getCmAnalyses <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- " + SELECT DISTINCT + cma.analysis_id, + cma.description as names + FROM + @schema.@cm_table_prefixresult cmds + INNER JOIN + @schema.@cm_table_prefixanalysis cma + ON cmds.analysis_id = cma.analysis_id + ; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix + ) + + res <- result$analysisId + names(res) <- result$names + + return( + res + ) + +} diff --git a/R/cohort-method-populationCharacteristics.R b/R/cohort-method-populationCharacteristics.R index 56cfd621..0951d3bd 100644 --- a/R/cohort-method-populationCharacteristics.R +++ b/R/cohort-method-populationCharacteristics.R @@ -39,7 +39,6 @@ cohortMethodPopulationCharacteristicsViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @@ -50,7 +49,6 @@ cohortMethodPopulationCharacteristicsViewer <- function(id) { cohortMethodPopulationCharacteristicsServer <- function( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) { @@ -68,7 +66,7 @@ cohortMethodPopulationCharacteristicsServer <- function( text <- "Table 2. Select characteristics before and after propensity score adjustment, showing the (weighted) percentage of subjects with the characteristics in the target (%s) and comparator (%s) group, as well as the standardized difference of the means." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } }) @@ -80,9 +78,9 @@ cohortMethodPopulationCharacteristicsServer <- function( balance <- getCohortMethodPopChar( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, databaseId = row$databaseId, analysisId = row$analysisId ) diff --git a/R/cohort-method-power.R b/R/cohort-method-power.R index f68dabf3..3f9626ae 100644 --- a/R/cohort-method-power.R +++ b/R/cohort-method-power.R @@ -42,10 +42,8 @@ cohortMethodPowerViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' @param metaAnalysisDbIds metaAnalysisDbIds #' #' @return #' the PLE systematic error power server @@ -54,10 +52,8 @@ cohortMethodPowerViewer <- function(id) { cohortMethodPowerServer <- function( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) { shiny::moduleServer( @@ -67,12 +63,12 @@ cohortMethodPowerServer <- function( output$powerTableCaption <- shiny::renderUI({ row <- selectedRow() - if (!is.null(row)) { + if (!is.null(row$target)) { text <- "Table 1a. Number of subjects, follow-up time (in years), number of outcome events, and event incidence rate (IR) per 1,000 patient years (PY) in the target (%s) and comparator (%s) group after propensity score adjustment, as well as the minimum detectable relative risk (MDRR). Note that the IR does not account for any stratification." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } else { return(NULL) } @@ -80,7 +76,7 @@ cohortMethodPowerServer <- function( output$powerTable <- shiny::renderTable({ row <- selectedRow() - if (is.null(row)) { + if (is.null(row$target)) { return(NULL) } else { table <- prepareCohortMethodPowerTable( @@ -88,8 +84,6 @@ cohortMethodPowerServer <- function( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) - table$description <- NULL - table$databaseId <- NULL if (!row$unblind) { table$targetOutcomes <- NA table$comparatorOutcomes <- NA @@ -112,11 +106,11 @@ cohortMethodPowerServer <- function( output$timeAtRiskTableCaption <- shiny::renderUI({ row <- selectedRow() - if (!is.null(row)) { + if (!is.null(row$target)) { text <- "Table 1b. Time (days) at risk distribution expressed as minimum (min), 25th percentile (P25), median, 75th percentile (P75), and maximum (max) in the target (%s) and comparator (%s) cohort after propensity score adjustment." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } else { return(NULL) } @@ -124,15 +118,15 @@ cohortMethodPowerServer <- function( output$timeAtRiskTable <- shiny::renderTable({ row <- selectedRow() - if (is.null(row)) { + if (is.null(row$target)) { return(NULL) } else { followUpDist <- getCmFollowUpDist( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -143,3 +137,151 @@ cohortMethodPowerServer <- function( }) }) } + + +prepareCohortMethodFollowUpDistTable <- function(followUpDist) { + targetRow <- data.frame(Database = followUpDist$databaseId, + Cohort = "Target", + Min = followUpDist$targetMinDays, + P10 = followUpDist$targetP10Days, + P25 = followUpDist$targetP25Days, + Median = followUpDist$targetMedianDays, + P75 = followUpDist$targetP75Days, + P90 = followUpDist$targetP90Days, + Max = followUpDist$targetMaxDays) + comparatorRow <- data.frame(Database = followUpDist$databaseId, + Cohort = "Comparator", + Min = followUpDist$comparatorMinDays, + P10 = followUpDist$comparatorP10Days, + P25 = followUpDist$comparatorP25Days, + Median = followUpDist$comparatorMedianDays, + P75 = followUpDist$comparatorP75Days, + P90 = followUpDist$comparatorP90Days, + Max = followUpDist$comparatorMaxDays) + table <- rbind(targetRow, comparatorRow) + table$Min <- formatC(table$Min, big.mark = ",", format = "d") + table$P10 <- formatC(table$P10, big.mark = ",", format = "d") + table$P25 <- formatC(table$P25, big.mark = ",", format = "d") + table$Median <- formatC(table$Median, big.mark = ",", format = "d") + table$P75 <- formatC(table$P75, big.mark = ",", format = "d") + table$P90 <- formatC(table$P90, big.mark = ",", format = "d") + table$Max <- formatC(table$Max, big.mark = ",", format = "d") + if (length(unique(followUpDist$databaseId)) == 1) + table$Database <- NULL + return(table) +} + + +prepareCohortMethodPowerTable <- function( + mainResults, + connectionHandler , + resultDatabaseSettings +) { + #analyses <- getCohortMethodAnalyses( + # connectionHandler = connectionHandler, + # resultDatabaseSettings = resultDatabaseSettings + #) + #table <- merge(mainResults, analyses) + table <- mainResults + alpha <- 0.05 + power <- 0.8 + z1MinAlpha <- stats::qnorm(1 - alpha/2) + zBeta <- -stats::qnorm(1 - power) + pA <- table$targetSubjects/(table$targetSubjects + table$comparatorSubjects) + pB <- 1 - pA + totalEvents <- abs(table$targetOutcomes) + abs(table$comparatorOutcomes) + table$mdrr <- exp(sqrt((zBeta + z1MinAlpha)^2/(totalEvents * pA * pB))) + table$targetYears <- table$targetDays/365.25 + table$comparatorYears <- table$comparatorDays/365.25 + table$targetIr <- 1000 * table$targetOutcomes/table$targetYears + table$comparatorIr <- 1000 * table$comparatorOutcomes/table$comparatorYears + table <- table[, c("targetSubjects", + "comparatorSubjects", + "targetYears", + "comparatorYears", + "targetOutcomes", + "comparatorOutcomes", + "targetIr", + "comparatorIr", + "mdrr"), drop = F] + table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") + table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") + table$targetYears <- formatC(table$targetYears, big.mark = ",", format = "d") + table$comparatorYears <- formatC(table$comparatorYears, big.mark = ",", format = "d") + table$targetOutcomes <- formatC(table$targetOutcomes, big.mark = ",", format = "d") + table$comparatorOutcomes <- formatC(table$comparatorOutcomes, big.mark = ",", format = "d") + table$targetIr <- sprintf("%.2f", table$targetIr) + table$comparatorIr <- sprintf("%.2f", table$comparatorIr) + table$mdrr <- sprintf("%.2f", table$mdrr) + table$targetSubjects <- gsub("^-", "<", table$targetSubjects) + table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) + table$targetOutcomes <- gsub("^-", "<", table$targetOutcomes) + table$comparatorOutcomes <- gsub("^-", "<", table$comparatorOutcomes) + table$targetIr <- gsub("^-", "<", table$targetIr) + table$comparatorIr <- gsub("^-", "<", table$comparatorIr) + idx <- (table$targetOutcomes < 0 | table$comparatorOutcomes < 0) + table$mdrr[idx] <- paste0(">", table$mdrr[idx]) + return(table) +} + + +getCohortMethodAnalyses <- function( + connectionHandler, + resultDatabaseSettings +) { + sql <- " + SELECT + cma.* + FROM + @schema.@cm_table_prefixanalysis cma + " + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix + ) + ) +} + +getCmFollowUpDist <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + outcomeId, + databaseId = NULL, + analysisId +) { + + if(is.null(targetId)){ + return(NULL) + } + + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixfollow_up_dist cmfud + WHERE + cmfud.target_id = @target_id + AND cmfud.comparator_id = @comparator_id + AND cmfud.outcome_id = @outcome_id + AND cmfud.analysis_id = @analysis_id + " + if(!is.null(databaseId)) { + sql <- paste(sql, paste("AND cmfud.database_id = '@database_id'"), collapse = "\n") + } + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + analysis_id = analysisId, + database_id = databaseId + ) + ) +} diff --git a/R/cohort-method-propensityModel.R b/R/cohort-method-propensityModel.R index 343a9829..5ce5f48a 100644 --- a/R/cohort-method-propensityModel.R +++ b/R/cohort-method-propensityModel.R @@ -39,7 +39,6 @@ cohortMethodPropensityModelViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @@ -50,7 +49,6 @@ cohortMethodPropensityModelViewer <- function(id) { cohortMethodPropensityModelServer <- function( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) { @@ -67,8 +65,8 @@ cohortMethodPropensityModelServer <- function( model <- getCohortMethodPropensityModel( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + targetId = row$targetId, + comparatorId = row$comparatorId, databaseId = row$databaseId, analysisId = row$analysisId ) @@ -94,3 +92,79 @@ cohortMethodPropensityModelServer <- function( } ) } + + +getCohortMethodPropensityModel <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId +) { + sqlTmp <- " + SELECT + cmpm.coefficient, + cmc.covariate_id, + cmc.covariate_name + FROM + @schema.@cm_table_prefixcovariate cmc + JOIN @schema.@cm_table_prefixpropensity_model cmpm + ON cmc.covariate_id = cmpm.covariate_id + AND cmc.database_id = cmpm.database_id + WHERE + cmpm.target_id = @target_id + AND cmpm.comparator_id = @comparator_id + AND cmpm.analysis_id = @analysis_id + AND cmpm.database_id = '@database_id' + " + + sql <- " + SELECT + cmc.covariate_id, + cmc.covariate_name, + cmpm.coefficient + FROM + ( + SELECT + covariate_id, + covariate_name + FROM + @schema.@cm_table_prefixcovariate + WHERE + analysis_id = @analysis_id + AND database_id = '@database_id' + UNION + SELECT + 0 as covariate_id, + 'intercept' as covariate_name) cmc + JOIN @schema.@cm_table_prefixpropensity_model cmpm + ON cmc.covariate_id = cmpm.covariate_id + WHERE + cmpm.target_id = @target_id + AND cmpm.comparator_id = @comparator_id + AND cmpm.analysis_id = @analysis_id + AND cmpm.database_id = '@database_id' + " + + model <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + return(model) +} + +prepareCohortMethodPropensityModelTable <- function(model) { + rnd <- function(x) { + ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) + } + table <- model[order(-abs(model$coefficient)), c("coefficient", "covariateName")] + table$coefficient <- sprintf("%.2f", table$coefficient) + colnames(table) <- c("Beta", "Covariate") + return(table) +} \ No newline at end of file diff --git a/R/cohort-method-propensityScoreDistribution.R b/R/cohort-method-propensityScoreDistribution.R index ce0e596b..0ece5fd5 100644 --- a/R/cohort-method-propensityScoreDistribution.R +++ b/R/cohort-method-propensityScoreDistribution.R @@ -46,7 +46,6 @@ cohortMethodPropensityScoreDistViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database #' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds @@ -58,7 +57,6 @@ cohortMethodPropensityScoreDistViewer <- function(id) { cohortMethodPropensityScoreDistServer <- function( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings, metaAnalysisDbIds = F @@ -70,14 +68,14 @@ cohortMethodPropensityScoreDistServer <- function( psDistPlot <- shiny::reactive({ row <- selectedRow() - if (is.null(row)) { + if (is.null(row$targetId)) { return(NULL) } else { ps <- getCohortMethodPs( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + targetId = row$targetId, + comparatorId = row$comparatorId, analysisId = row$analysisId, databaseId = row$databaseId ) @@ -86,17 +84,11 @@ cohortMethodPropensityScoreDistServer <- function( return(NULL) #TODO: handle more gracefully } - targetName <- getCohortNameFromId( - connectionHandler = connectionHandler , - resultDatabaseSettings = resultDatabaseSettings, - cohortId = inputParams()$target - ) - comparatorName <- getCohortNameFromId( - connectionHandler = connectionHandler , - resultDatabaseSettings = resultDatabaseSettings, - cohortId = inputParams()$comparator - ) - plot <- plotCohortMethodPs(ps, targetName$cohortName, comparatorName$cohortName) + targetName <- row$target + + comparatorName <- row$comparator + + plot <- plotCohortMethodPs(ps, targetName, comparatorName) return(plot) } }) @@ -121,11 +113,55 @@ cohortMethodPropensityScoreDistServer <- function( ) } - +getCohortMethodPs <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId = NULL +) { + if(is.null(targetId)){ + return(NULL) + } + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixpreference_score_dist cmpsd + WHERE + cmpsd.target_id = @target_id + AND cmpsd.comparator_id = @comparator_id + AND cmpsd.analysis_id = @analysis_id + " + if(!is.null(databaseId)) { + sql <- paste(sql, paste("AND cmpsd.database_id = '@database_id'"), collapse = "\n") + } + + + ps <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + + + if (!is.null(databaseId)) { + ps$databaseId <- NULL + } + return(ps) +} # CohortMethod-propensityScoreDist plotCohortMethodPs <- function(ps, targetName, comparatorName) { - if (is.null(ps$databaseId)) { + if(is.null(ps$preferenceScore)){ + return(NULL) + } + if(is.null(ps$databaseId)) { ps <- rbind(data.frame(x = ps$preferenceScore, y = ps$targetDensity, group = targetName), data.frame(x = ps$preferenceScore, y = ps$comparatorDensity, group = comparatorName)) diff --git a/R/cohort-method-resultSummary.R b/R/cohort-method-resultSummary.R new file mode 100644 index 00000000..e90981b1 --- /dev/null +++ b/R/cohort-method-resultSummary.R @@ -0,0 +1,358 @@ +# @file cohort-method-resultSummary +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + + +#' The module viewer for rendering the cohort method results +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method diagnostics viewer +#' +#' @export +cohortMethodResultSummaryViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::tabsetPanel( + type = 'hidden', + id = ns('resultPanel'), + + shiny::tabPanel( + title = "Table", + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Summary'), + solidHeader = TRUE, + resultTableViewer(ns("resultSummaryTable")) + ) + ), + + shiny::tabPanel( + title = "Results", + shiny::actionButton( + inputId = ns('goBackCmResults'), + label = "Back To Result Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + cohortMethodFullResultViewer(ns("cmFullResults")) + ) + + ) + + +} + + +#' The module server for rendering the PLE diagnostics summary +#' +#' @param id the unique reference id for the module +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user +#' +#' @return +#' the PLE diagnostics summary results +#' +#' @export +cohortMethodResultSummaryServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + shiny::observeEvent( + eventExpr = input$goBackCmResults, + { + shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") + }) + + data <- shiny::reactive({ + getCmResultData( + connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + }) + + resultTableOutputs <- resultTableServer( + id = "resultSummaryTable", + df = data, + colDefsInput = getCmResultSummaryTableColDef(), + addActions = c('results') + ) + + selectedRow <- shiny::reactiveVal(value = NULL) + shiny::observeEvent(resultTableOutputs$actionCount(), { + if(resultTableOutputs$actionType() == 'results'){ + selectedRow(data()[resultTableOutputs$actionIndex()$index,]) + shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") + } + }) + + cohortMethodFullResultServer( + id = "cmFullResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow + ) + + } + ) +} + + +getCmResultSummaryTableColDef <- function(){ + result <- list( + + analysisId = reactable::colDef(show = F), + description = reactable::colDef( + header = withTooltip( + "Analysis", + "The analysis description" + ), + minWidth = 140 + ), + databaseId = reactable::colDef(show = F), + + cdmSourceAbbreviation = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ) + ), + + targetId = reactable::colDef(show = F), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest" + ), + minWidth = 300 + ), + + comparatorId = reactable::colDef(show = F), + comparator = reactable::colDef( + header = withTooltip( + "Comparator", + "The comparator cohort of interest" + ), + minWidth = 300 + ), + + outcomeId = reactable::colDef(show = F), + outcome = reactable::colDef( + header = withTooltip( + "Outcome", + "The outcome of interest" + ), + minWidth = 300 + ), + + rr = reactable::colDef( + header = withTooltip( + "rr", + "The uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Lb = reactable::colDef( + header = withTooltip( + "ci95Lb", + "The lower bound of the 95% confidence internval of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Ub = reactable::colDef( + header = withTooltip( + "ci95Ub", + "The upper bound of the 95% confidence internval of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + p = reactable::colDef( + header = withTooltip( + "p", + "The p value of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedRr = reactable::colDef( + header = withTooltip( + "calibrated rr", + "The calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedCi95Lb = reactable::colDef( + header = withTooltip( + "calibrated ci95Lb", + "The lower bound of the 95% confidence internval of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedCi95Ub = reactable::colDef( + header = withTooltip( + "calibrated ci95Ub", + "The upper bound of the 95% confidence internval of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedP = reactable::colDef( + header = withTooltip( + "calibrated p", + "The p value of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + logRr = reactable::colDef(show = F), + seLogRr = reactable::colDef(show = F), + targetSubjects = reactable::colDef(show = F), + comparatorSubjects = reactable::colDef(show = F), + targetDays = reactable::colDef(show = F), + comparatorDays = reactable::colDef(show = F), + targetOutcomes = reactable::colDef(show = F), + comparatorOutcomes = reactable::colDef(show = F), + calibratedLogRr = reactable::colDef(show = F), + calibratedSeLogRr = reactable::colDef(show = F), + calibratedSeLogRr = reactable::colDef(show = F), + unblind = reactable::colDef(show = F) + ) + + return(result) +} + +getCmResultData <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + targetIds = inputSelected()$targetIds + outcomeIds = inputSelected()$outcomeIds + comparatorIds = inputSelected()$comparatorIds + analysisIds = inputSelected()$analysisIds + + if(is.null(comparatorIds) || is.null(targetIds) || is.null(outcomeIds) || is.null(analysisIds)){ + return(NULL) + } + + sql <- " + SELECT + cma.analysis_id, + cma.description description, + dmd.database_id database_id, + dmd.cdm_source_abbreviation cdm_source_abbreviation, + cmr.target_id, + cg1.cohort_name as target, + cmr.outcome_id, + cg2.cohort_name as outcome, + cmr.comparator_id, + cg3.cohort_name as comparator, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.rr end rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.ci_95_lb end ci_95_lb, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.ci_95_ub end ci_95_ub, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.p end p, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.log_rr end log_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.se_log_rr end se_log_rr, + cmr.target_subjects, + cmr.comparator_subjects, + cmr.target_days, + cmr.comparator_days, + cmr.target_outcomes, + cmr.comparator_outcomes, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_rr end calibrated_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_ci_95_lb end calibrated_ci_95_lb, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_ci_95_ub end calibrated_ci_95_ub, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_p end calibrated_p, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_log_rr end calibrated_log_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_se_log_rr end calibrated_se_log_rr, + COALESCE(cmds.unblind, 0) unblind +FROM + @schema.@cm_table_prefixanalysis cma + JOIN @schema.@cm_table_prefixresult cmr + on cmr.analysis_id = cma.analysis_id + + JOIN @schema.@database_table dmd + on dmd.database_id = cmr.database_id + + LEFT JOIN @schema.@cm_table_prefixdiagnostics_summary cmds + on cmds.analysis_id = cmr.analysis_id + AND cmds.target_id = cmr.target_id + AND cmds.comparator_id = cmr.comparator_id + AND cmds.outcome_id = cmr.outcome_id + AND cmds.database_id = cmr.database_id + + inner join @schema.@cg_table_prefixcohort_definition cg1 + on cg1.cohort_definition_id = cmr.target_id + + inner join @schema.@cg_table_prefixcohort_definition cg2 + on cg2.cohort_definition_id = cmr.outcome_id + + inner join @schema.@cg_table_prefixcohort_definition cg3 + on cg3.cohort_definition_id = cmr.comparator_id + + where cmr.target_id in (@targets) + {@use_comparators}?{and cmr.comparator_id in (@comparators)} + and cmr.outcome_id in (@outcomes) + {@use_analyses}?{and cmr.analysis_id in (@analyses)} + ; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + + targets = paste0(targetIds, collapse = ','), + comparators = paste0(comparatorIds, collapse = ','), + outcomes = paste0(outcomeIds, collapse = ','), + analyses = paste0(analysisIds, collapse = ','), + + use_comparators = !is.null(comparatorIds), + use_analyses = !is.null(analysisIds) + ) + + return( + result + ) +} \ No newline at end of file diff --git a/R/cohort-method-resultsTable.R b/R/cohort-method-resultsTable.R deleted file mode 100644 index 1b27fa17..00000000 --- a/R/cohort-method-resultsTable.R +++ /dev/null @@ -1,209 +0,0 @@ -# @file cohort-method-resultsTable -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. - - - - - -#' The module viewer for rendering the PLE main results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the PLE main results -#' -#' @export -cohortMethodResultsTableViewer <- function(id) { - ns <- shiny::NS(id) - - reactable::reactableOutput(outputId = ns("mainTable")) -} - - - - -#' The module server for rendering the PLE results per current selections -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param inputParams the selected study parameters of interest -#' @param resultDatabaseSettings a list containing the result schema and prefixes -#' -#' @return -#' the PLE main results table server server -#' -#' @export -cohortMethodResultsTableServer <- function( - id, - connectionHandler, - inputParams, - resultDatabaseSettings - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - - - mainColumns <- c("description", - "cdmSourceAbbreviation", - "rr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedRr", - "calibratedCi95Lb", - "calibratedCi95Ub", - "calibratedP") - - resultSubset <- shiny::reactive({ - - results <- getCohortMethodMainResults( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetIds = filterCohortMethodEmptyNullValues(inputParams()$target), - comparatorIds = filterCohortMethodEmptyNullValues(inputParams()$comparator), - outcomeIds = filterCohortMethodEmptyNullValues(inputParams()$outcome), - databaseIds = filterCohortMethodEmptyNullValues(inputParams()$database), - analysisIds = filterCohortMethodEmptyNullValues(inputParams()$analysis) - ) - results <- results[order(results$analysisId), ] - - - results[which(results$unblind == 0), getCohortMethodColumnsToBlind(results)] <- NA - - return(results) - }) - - selectedRow <- shiny::reactive({ - idx <- reactable::getReactableState( - outputId = 'mainTable', - name = 'selected' - ) - if (is.null(idx)) { - return(NULL) - } else { - subset <- resultSubset() - if (nrow(subset) == 0) { - return(NULL) - } - row <- subset[idx, ] - # row$psStrategy <- gsub("^PS ", "", gsub(", .*$", "", cohortMethodAnalysis$description[cohortMethodAnalysis$analysisId == row$analysisId])) - return(row) - } - }) - - output$mainTable <- reactable::renderReactable({ - table <- resultSubset() - if (is.null(table) || nrow(table) == 0) { - shiny::validate(shiny::need(nrow(table) > 0, "No CM results for selections.")) - return(NULL) - } - table <- table[, mainColumns] - table$rr <- prettyCohortMethodHr(table$rr) - table$ci95Lb <- prettyCohortMethodHr(table$ci95Lb) - table$ci95Ub <- prettyCohortMethodHr(table$ci95Ub) - table$p <- prettyCohortMethodHr(table$p) - table$calibratedRr <- prettyCohortMethodHr(table$calibratedRr) - table$calibratedCi95Lb <- prettyCohortMethodHr(table$calibratedCi95Lb) - table$calibratedCi95Ub <- prettyCohortMethodHr(table$calibratedCi95Ub) - table$calibratedP <- prettyCohortMethodHr(table$calibratedP) - #colnames(table) <- mainColumnNames - - reactable::reactable( # add extras - data = table, - rownames = FALSE, - defaultPageSize = 15, - showPageSizeOptions = T, - onClick = 'select', - selection = 'single', - striped = T, - - columns = list( - description = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Analysis", - "Analysis" - )), - cdmSourceAbbreviation = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Data source", - "Data source" - )), - rr = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "HR", - "Hazard ratio (uncalibrated)" - )), - ci95Lb = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "LB", - "Lower bound of the 95 percent confidence interval (uncalibrated)" - )), - ci95Ub = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "UB", - "Upper bound of the 95 percent confidence interval (uncalibrated)" - )), - p = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "P", - "Two-sided p-value (uncalibrated)" - )), - calibratedRr = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.HR", - "Hazard ratio (calibrated)" - )), - calibratedCi95Lb = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.LB", - "Lower bound of the 95 percent confidence interval (calibrated)" - )), - calibratedCi95Ub = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.UB", - "Upper bound of the 95 percent confidence interval (calibrated)" - )), - calibratedP = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.P", - "Two-sided p-value (calibrated)" - )) - ) - ) - }) - - return(selectedRow) - }) -} diff --git a/R/cohort-method-subgroups.R b/R/cohort-method-subgroups.R deleted file mode 100644 index 1c6d3269..00000000 --- a/R/cohort-method-subgroups.R +++ /dev/null @@ -1,138 +0,0 @@ -# @file cohort-method-subgroups -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. - - -#' The module viewer for rendering the PLE subgroup results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort method subgroup results module -#' -#' @export -cohortMethodSubgroupsViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::uiOutput(outputId = ns("subgroupTableCaption")), - DT::dataTableOutput(outputId = ns("subgroupTable")) - ) -} - - -#' The module server for rendering the subgroup results -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param exposureOfInterest exposureOfInterest -#' @param outcomeOfInterest outcomeOfInterest -#' @param connectionHandler connection -#' -#' @return -#' the PLE subgroup results server -#' -#' @export -cohortMethodSubgroupsServer <- function( - id, - selectedRow, - inputParams, - exposureOfInterest, - outcomeOfInterest, - connectionHandler - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - - interactionEffects <- shiny::reactive({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - targetId <- exposureOfInterest$exposureId[exposureOfInterest$exposureName == inputParams()$target] - comparatorId <- exposureOfInterest$exposureId[exposureOfInterest$exposureName == inputParams()$comparator] - outcomeId <- outcomeOfInterest$outcomeId[outcomeOfInterest$outcomeName == inputParams()$outcome] - subgroupResults <- getCohortMethodSubgroupResults(connectionHandler = connectionHandler, - targetIds = targetId, - comparatorIds = comparatorId, - outcomeIds = outcomeId, - databaseIds = row$databaseId, - analysisIds = row$analysisId) - if (nrow(subgroupResults) == 0) { - return(NULL) - } else { - if (!row$unblind) { - subgroupResults$rrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$ci95Lb <- rep(NA, nrow(subgroupResults)) - subgroupResults$ci95Ub <- rep(NA, nrow(subgroupResults)) - subgroupResults$logRrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$seLogRrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$p <- rep(NA, nrow(subgroupResults)) - subgroupResults$calibratedP <- rep(NA, nrow(subgroupResults)) - } - return(subgroupResults) - } - } - }) - - output$subgroupTableCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - text <- "Table 4. Subgroup interactions. For each subgroup, the number of subject within the subroup - in the target (%s) and comparator (%s) cohorts are provided, as well as the hazard ratio ratio (HRR) - with 95 percent confidence interval and p-value (uncalibrated and calibrated) for interaction of the main effect with - the subgroup." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) - } - }) - - output$subgroupTable <- DT::renderDataTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - subgroupResults <- interactionEffects() - if (is.null(subgroupResults)) { - return(NULL) - } - subgroupTable <- prepareCohortMethodSubgroupTable(subgroupResults, output = "html") - colnames(subgroupTable) <- c("Subgroup", - "Target subjects", - "Comparator subjects", - "HRR", - "P", - "Cal.P") - options <- list(searching = FALSE, - ordering = FALSE, - paging = FALSE, - bInfo = FALSE) - subgroupTable <- DT::datatable(subgroupTable, - options = options, - rownames = FALSE, - escape = FALSE, - class = "stripe nowrap compact") - return(subgroupTable) - } - }) - } - ) -} diff --git a/R/cohort-method-systematicError.R b/R/cohort-method-systematicError.R index c2a2af16..1c826246 100644 --- a/R/cohort-method-systematicError.R +++ b/R/cohort-method-systematicError.R @@ -36,20 +36,12 @@ cohortMethodSystematicErrorViewer <- function(id) { estimator should have the true effect size within the 95 percent confidence interval 95 percent of times."), shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPng"), - label = "Download plot as PNG"), + label = "Download plot as PNG"), shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPdf"), - label = "Download plot as PDF") - ), - shiny::conditionalPanel(condition = "output.isMetaAnalysis == true", - ns = ns, - shiny::plotOutput(outputId = ns("systematicErrorSummaryPlot")), - shiny::div(shiny::strong("Figure 8."),"Fitted null distributions per data source."), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadSystematicErrorSummaryPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadSystematicErrorSummaryPlotPdf"), - label = "Download plot as PDF"))) - ) + label = "Download plot as PDF") + ) + ) + } @@ -58,10 +50,8 @@ cohortMethodSystematicErrorViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection handler to the result databases #' @param resultDatabaseSettings a list containing the result schema and prefixes -#' @param metaAnalysisDbIds metaAnalysisDbIds #' #' @return #' the PLE systematic error content server @@ -70,28 +60,14 @@ cohortMethodSystematicErrorViewer <- function(id) { cohortMethodSystematicErrorServer <- function( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) { shiny::moduleServer( id, function(input, output, session) { - output$isMetaAnalysis <- shiny::reactive({ - return(FALSE) - # TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - - - systematicErrorPlot <- shiny::reactive({ row <- selectedRow() if (is.null(row)) { @@ -100,8 +76,8 @@ cohortMethodSystematicErrorServer <- function( controlResults <- getCohortMethodControlResults( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + targetId = row$targetId, + comparatorId = row$comparatorId, analysisId = row$analysisId, databaseId = row$databaseId ) @@ -123,54 +99,183 @@ cohortMethodSystematicErrorServer <- function( return(systematicErrorPlot()) }) - output$downloadSystematicErrorPlotPng <- shiny::downloadHandler(filename = "SystematicError.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = systematicErrorPlot(), width = 12, height = 5.5, dpi = 400) - }) - - output$downloadSystematicErrorPlotPdf <- shiny::downloadHandler(filename = "SystematicError.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = systematicErrorPlot(), width = 12, height = 5.5) - }) - - systematicErrorSummaryPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row) || !(row$databaseId %in% metaAnalysisDbIds)) { - return(NULL) - } else { - ##negativeControls <- getCohortMethodNegativeControlEstimates(connection = connection, - ## #resultsSchema = resultsSchema, unused argument - ## targetId = inputParams()$target, - ## comparatorId = inputParams()$comparator, - ## analysisId = row$analysisId) - ##if (is.null(negativeControls)) - return(NULL) - - ## plotCohortMethodEmpiricalNulls() not found - #plot <- plotCohortMethodEmpiricalNulls(negativeControls) - ##return(plot) + output$downloadSystematicErrorPlotPng <- shiny::downloadHandler( + filename = "SystematicError.png", + contentType = "image/png", + content = function(file) { + ggplot2::ggsave(file, plot = systematicErrorPlot(), width = 12, height = 5.5, dpi = 400) } - }) - - output$systematicErrorSummaryPlot <- shiny::renderPlot({ - return(systematicErrorSummaryPlot()) - }, res = 100) - - output$downloadSystematicErrorSummaryPlotPng <- shiny::downloadHandler(filename = "SystematicErrorSummary.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = systematicErrorSummaryPlot(), width = 12, height = 5.5, dpi = 400) - }) - - output$downloadSystematicErrorSummaryPlotPdf <- shiny::downloadHandler(filename = "SystematicErrorSummary.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = systematicErrorSummaryPlot(), width = 12, height = 5.5) - }) + ) + output$downloadSystematicErrorPlotPdf <- shiny::downloadHandler( + filename = "SystematicError.pdf", + contentType = "application/pdf", + content = function(file) { + ggplot2::ggsave(file = file, plot = systematicErrorPlot(), width = 12, height = 5.5) + } + ) } ) } + + +getCohortMethodControlResults <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId = NULL, + includePositiveControls = TRUE, + emptyAsNa = TRUE +) { + + sql <- " + SELECT + cmr.*, + cmtco.true_effect_size effect_size + FROM + @schema.@cm_table_prefixresult cmr + JOIN @schema.@cm_table_prefixtarget_comparator_outcome cmtco + ON cmr.target_id = cmtco.target_id AND cmr.comparator_id = cmtco.comparator_id AND cmr.outcome_id = cmtco.outcome_id + WHERE + cmtco.outcome_of_interest != 1 + AND cmr.target_id = @target_id + AND cmr.comparator_id = @comparator_id + AND cmr.analysis_id = @analysis_id + " + + + if (!is.null(databaseId)) { + # update sql + sql <- paste(sql, paste("AND cmr.database_id = '@database_id'"), collapse = "\n") + } + + if (!includePositiveControls) { + # update sql + sql <- paste(sql, paste("AND cmtco.true_effect_size = 1"), collapse = "\n") + } + + results <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + + if (emptyAsNa) { + results[results == ''] <- NA + } + + return(results) +} + + +plotCohortMethodScatter <- function(controlResults) { + + if(nrow(controlResults)==0){ + return(NULL) + } + + size <- 2 + labelY <- 0.7 + d <- rbind(data.frame(yGroup = "Uncalibrated", + logRr = controlResults$logRr, + seLogRr = controlResults$seLogRr, + ci95Lb = controlResults$ci95Lb, + ci95Ub = controlResults$ci95Ub, + trueRr = controlResults$effectSize), + data.frame(yGroup = "Calibrated", + logRr = controlResults$calibratedLogRr, + seLogRr = controlResults$calibratedSeLogRr, + ci95Lb = controlResults$calibratedCi95Lb, + ci95Ub = controlResults$calibratedCi95Ub, + trueRr = controlResults$effectSize)) + d <- d[!is.na(d$logRr), ] + d <- d[!is.na(d$ci95Lb), ] + d <- d[!is.na(d$ci95Ub), ] + if (nrow(d) == 0) { + return(NULL) + } + d$Group <- as.factor(d$trueRr) + d$Significant <- d$ci95Lb > d$trueRr | d$ci95Ub < d$trueRr + temp1 <- stats::aggregate(Significant ~ Group + yGroup, data = d, length) + temp2 <- stats::aggregate(Significant ~ Group + yGroup, data = d, mean) + temp1$nLabel <- paste0(formatC(temp1$Significant, big.mark = ","), " estimates") + temp1$Significant <- NULL + + temp2$meanLabel <- paste0(formatC(100 * (1 - temp2$Significant), digits = 1, format = "f"), + "% of CIs include ", + temp2$Group) + temp2$Significant <- NULL + dd <- merge(temp1, temp2) + dd$tes <- as.numeric(as.character(dd$Group)) + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) + themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) + + d$Group <- paste("True hazard ratio =", d$Group) + dd$Group <- paste("True hazard ratio =", dd$Group) + alpha <- 1 - min(0.95 * (nrow(d)/nrow(dd)/50000)^0.1, 0.95) + plot <- ggplot2::ggplot(d, ggplot2::aes(x = .data$logRr, y = .data$seLogRr), environment = environment()) + + ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.025), slope = 1/stats::qnorm(0.025)), + colour = grDevices::rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.975), slope = 1/stats::qnorm(0.975)), + colour = grDevices::rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_point(size = size, + color = grDevices::rgb(0, 0, 0, alpha = 0.05), + alpha = alpha, + shape = 16) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::geom_label(x = log(0.15), + y = 0.9, + alpha = 1, + hjust = "left", + ggplot2::aes(label = .data$nLabel), + size = 5, + data = dd) + + ggplot2::geom_label(x = log(0.15), + y = labelY, + alpha = 1, + hjust = "left", + ggplot2::aes(label = .data$meanLabel), + size = 5, + data = dd) + + ggplot2::scale_x_continuous("Hazard ratio", + limits = log(c(0.1, 10)), + breaks = log(breaks), + labels = breaks) + + ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + + ggplot2::facet_grid(yGroup ~ Group) + + ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.text.y = themeRA, + axis.text.x = theme, + axis.title = theme, + legend.key = ggplot2::element_blank(), + strip.text.x = theme, + strip.text.y = theme, + strip.background = ggplot2::element_blank(), + legend.position = "none") + + return(plot) +} + + diff --git a/R/components-data-viewer.R b/R/components-data-viewer.R index 2a63d2c0..4dd67e54 100644 --- a/R/components-data-viewer.R +++ b/R/components-data-viewer.R @@ -163,10 +163,27 @@ resultTableServer <- function( id, function(input, output, session) { - if(inherits(df, 'data.frame')){ + # convert a data.frame to a reactive + if(!inherits(df, 'reactive')){ df <- shiny::reactiveVal(df) } + # initialize the reactables + actionCount <- shiny::reactiveVal(0) + actionIndex <- shiny::reactiveVal(0) + actionType <- shiny::reactiveVal('none') + + # add action column to data + newdf <- shiny::reactive({ + if(!is.null(nrow(df())) & !is.null(addActions)){ + cbind( + actions = rep("", nrow(df())), + df() + )} else{ + df() + } + }) + # add a new entry to colDefs with an action dropdown menu # add a onClick action if(!is.null(addActions)){ @@ -195,8 +212,8 @@ resultTableServer <- function( shinyWidgets::pickerInput( inputId = session$ns('dataCols'), label = 'Select Columns to Display: ', - choices = colnames(df()), - selected = colnames(df()), + choices = colnames(newdf()), + selected = colnames(newdf()), choicesOpt = list(style = rep_len("color: black;", 999)), multiple = T, options = shinyWidgets::pickerOptions( @@ -215,21 +232,35 @@ resultTableServer <- function( #need to try adding browser() to all reactives to see why selected cols isnt working colDefs <- shiny::reactive( + if(!is.null(newdf())){ create_colDefs_list( - df = df()[, input$dataCols], + df = newdf()[, input$dataCols], customColDefs = colDefsInput - ) ) + } else{ + NULL + } + ) output$resultData <- reactable::renderReactable({ if (is.null(input$dataCols)) { - data = df() + data = newdf() } else{ - data = df()[, input$dataCols, drop = FALSE] + data = newdf()[, input$dataCols, drop = FALSE] } - if (nrow(data) == 0) - return(NULL) + if(is.null(data)){ + return(NULL) + } + if(nrow(data) == 0){ + return(NULL) + } + # set row height based on nchar of table + if(max(apply(data, 1, function(x) max(nchar(x))), na.rm = T) < 100){ + height <- 40*3 + } else{ + height <- NULL + } reactable::reactable( data, @@ -247,12 +278,15 @@ resultTableServer <- function( highlight = TRUE, defaultColDef = reactable::colDef(align = "left"), - rowStyle = list(height = 40*3) + rowStyle = list( + height = height + ) #, experimental #theme = ohdsiReactableTheme ) }) + # download full data button output$downloadDataFull <- shiny::downloadHandler( filename = function() { @@ -269,9 +303,6 @@ resultTableServer <- function( # capture the actions - actionCount <- shiny::reactiveVal(0) - actionIndex <- shiny::reactiveVal(0) - actionType <- shiny::reactiveVal('none') shiny::observeEvent(input$action_index, { actionIndex(input$action_index) }) diff --git a/R/components.R b/R/components.R index be1bcdad..db45822e 100644 --- a/R/components.R +++ b/R/components.R @@ -20,7 +20,8 @@ inputSelectionViewer <- function(id = "input-selection") { shinydashboard::box( status = 'warning', width = "100%", - title = 'Selected: ', + title = 'Selected: ', + collapsible = T, shiny::uiOutput(ns("inputsText")) ) ) diff --git a/R/evidence-synth-main.R b/R/evidence-synth-main.R index 6e462e6f..c508fe99 100644 --- a/R/evidence-synth-main.R +++ b/R/evidence-synth-main.R @@ -118,26 +118,10 @@ evidenceSynthesisServer <- function( targetIds <- getESTargetIds( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings - #mySchema = resultDatabaseSettings$schema, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix ) outcomeIds <- getESOutcomeIds( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings - #mySchema = resultDatabaseSettings$schema, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix - ) - - diagnosticColumnNames <- getOACcombinations( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - #resultsSchema = resultDatabaseSettings$schema, - #sccsTablePrefix = resultDatabaseSettings$sccsTablePrefix, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - #databaseTable = resultDatabaseSettings$databaseMetaData ) inputSelected <- inputSelectionServer( @@ -146,7 +130,7 @@ evidenceSynthesisServer <- function( createInputSetting( rowNumber = 1, columnWidth = 6, - varName = 'targetId', + varName = 'targetIds', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( label = 'Target: ', @@ -165,7 +149,7 @@ evidenceSynthesisServer <- function( createInputSetting( rowNumber = 1, columnWidth = 6, - varName = 'outcomeId', + varName = 'outcomeIds', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( label = 'Outcome: ', @@ -189,12 +173,8 @@ evidenceSynthesisServer <- function( getCMEstimation( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - #mySchema = resultDatabaseSettings$schema, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - #databaseMetaData = resultDatabaseSettings$databaseMetaData, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds ) }) @@ -202,12 +182,8 @@ evidenceSynthesisServer <- function( getMetaEstimation( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - #mySchema = resultDatabaseSettings$schema, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - #esTablePrefix = resultDatabaseSettings$tablePrefix, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds ) }) @@ -215,36 +191,20 @@ evidenceSynthesisServer <- function( getEvidenceSynthDiagnostics( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - #resultsSchema = resultDatabaseSettings$schema, - #cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - #cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - #databaseTable = resultDatabaseSettings$databaseTable, - targetIds = inputSelected()$targetId, - outcomeIds = inputSelected()$outcomeId + inputSelected = inputSelected, + targetIds = inputSelected()$targetIds, + outcomeIds = inputSelected()$outcomeIds ) }) - customColDefs2 <- list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ), - sticky = "left" - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest " - ), - sticky = "left" - ) - ) resultTableServer( id = "diagnosticsSummaryTable", df = diagSumData, - colDefsInput = styleColumns(customColDefs2, diagnosticColumnNames, outcomeIds) + colDefsInput = getColDefsESDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) ) output$esCohortMethodPlot <- shiny::renderPlot( @@ -338,8 +298,8 @@ evidenceSynthesisServer <- function( getSccsEstimation( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds ) }) @@ -675,6 +635,10 @@ return(unique(result)) createPlotForAnalysis <- function(data) { + if(is.null(data$comparator)){ + return(NULL) + } + compText <- data.frame( comparatorText = paste0('Comp', 1:length(unique(data$comparator))), comparator = unique(data$comparator) @@ -762,6 +726,10 @@ getSccsEstimation <- function( outcomeId ){ + if(is.null(targetId)){ + return(NULL) + } + sql <- "select c1.cohort_name as target, c3.cohort_name as outcome, @@ -928,6 +896,10 @@ createPlotForSccsAnalysis <- function( data ){ + if(is.null(data)){ + return(NULL) + } + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) plot <- ggplot2::ggplot( data = data, @@ -1011,10 +983,15 @@ getOACcombinations <- function( getEvidenceSynthDiagnostics <- function( connectionHandler, resultDatabaseSettings, + inputSelected, targetIds, outcomeIds ){ + if(is.null(targetIds)){ + return(NULL) + } + sccsDiagTemp <- getSccsAllDiagnosticsSummary( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings, @@ -1024,11 +1001,14 @@ getEvidenceSynthDiagnostics <- function( cmDiagTemp <- getCmDiagnosticsData( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetIds = targetIds, - outcomeIds = outcomeIds + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected ) + if(is.null(cmDiagTemp) | is.null(sccsDiagTemp)){ + return(NULL) + } + # select columns of interest and rename for consistency sccsDiagTemp <- diagnosticSummaryFormat( data = shiny::reactive({sccsDiagTemp}), @@ -1052,3 +1032,67 @@ getEvidenceSynthDiagnostics <- function( # return return(allResult) } + + + +getColDefsESDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ), + sticky = "left" + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + sticky = "left" + ) + ) + + outcomes <- getESOutcomeIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + analyses <- getOACcombinations( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + colnameFormat <- merge(unique(names(analyses)), unique(names(outcomes))) + colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) + + styleList <- lapply( + colnameFormat, + FUN = function(x){ + reactable::colDef( + header = withTooltip( + substring(x,1,40), + x + ), + style = function(value) { + color <- 'orange' + if(is.na(value)){ + color <- 'black' + }else if(value == 'Pass'){ + color <- '#AFE1AF' + }else if(value == 'Fail'){ + color <- '#E97451' + } + list(background = color) + } + ) + } + ) + names(styleList) <- colnameFormat + result <- append(fixedColumns, styleList) + + return(result) +} \ No newline at end of file diff --git a/R/helpers-cohort-methodDataPulls.R b/R/helpers-cohort-methodDataPulls.R deleted file mode 100644 index 71c6d777..00000000 --- a/R/helpers-cohort-methodDataPulls.R +++ /dev/null @@ -1,713 +0,0 @@ - -getCohortNameFromId <- function( - connectionHandler, - resultDatabaseSettings, - cohortId) { - sql <- " - SELECT - cohort_name - FROM - @schema.@cg_table_prefixcohort_definition cd - WHERE - cd.cohort_definition_id = @cohort_id; - " - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - cohort_id = cohortId - ) - ) -} - - -getCohortMethodTcoChoice <- function( - connectionHandler, - resultDatabaseSettings, - tcoVar, - sorted = TRUE) { - sql <- " - SELECT - DISTINCT - cmtco.@tco_var, - cd.cohort_name -FROM - @schema.@cm_table_prefixtarget_comparator_outcome cmtco - join @schema.@cg_table_prefixcohort_definition cd - on cmtco.@tco_var = cd.cohort_definition_id - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n cd.cohort_name desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - tco_var = tcoVar - ) - ) -} - - -getCohortMethodTargetChoices <- function( - connectionHandler, - resultDatabaseSettings - ) { - return( - getCohortMethodTcoChoice( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - "target_id" - ) - ) -} - - -getCohortMethodComparatorChoices <- function( - connectionHandler, - resultDatabaseSettings - ) { - return( - getCohortMethodTcoChoice( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - "comparator_id" - ) - ) -} - - -getCohortMethodOutcomeChoices <- function( - connectionHandler, - resultDatabaseSettings - ) { - return( - getCohortMethodTcoChoice( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - "outcome_id" - ) - ) -} - - -getCohortMethodDatabaseChoices <- function( - connectionHandler, - resultDatabaseSettings, - sorted = TRUE - ) { - sql <- " -SELECT -DISTINCT -dmd.database_id, -dmd.cdm_source_abbreviation -FROM - @schema.@cm_table_prefixresult cmr - join @schema.@database_table dmd - on dmd.database_id = cmr.database_id - - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n dmd.cdm_source_abbreviation desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - database_table = resultDatabaseSettings$databaseTable - ) - ) -} - - -getCmAnalysisOptions <- function( - connectionHandler, - resultDatabaseSettings, - sorted = TRUE) { - sql <- " -SELECT -DISTINCT -cma.analysis_id, -cma.description -FROM - @schema.@cm_table_prefixanalysis cma - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n cma.description desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix - ) - ) -} - -getAllCohortMethodResults <- function( - connectionHandler, - resultDatabaseSettings - ) { - sql <- " -SELECT - cma.analysis_id, - cma.description description, - dmd.database_id database_id, -- break? - dmd.cdm_source_abbreviation cdm_source_abbreviation, - cmr.rr rr, - cmr.ci_95_lb ci_95_lb, - cmr.ci_95_ub ci_95_ub, - cmr.p p, - cmr.log_rr, - cmr.se_log_rr, - cmr.target_subjects, - cmr.comparator_subjects, - cmr.target_days, - cmr.comparator_days, - cmr.target_outcomes, - cmr.comparator_outcomes, - cmr.calibrated_rr calibrated_rr, - cmr.calibrated_ci_95_lb calibrated_ci_95_lb, - cmr.calibrated_ci_95_ub calibrated_ci_95_ub, - cmr.calibrated_p calibrated_p, - cmr.calibrated_log_rr, - cmr.calibrated_se_log_rr, - COALESCE(cmds.unblind, 0) unblind -- TODO: assume unblinded? (or always populated and moot) -FROM - @schema.@cm_table_prefixanalysis cma - JOIN @schema.@cm_table_prefixresult cmr on cmr.analysis_id = cma.analysis_id - JOIN @schema.@database_table dmd on dmd.database_id = cmr.database_id - LEFT JOIN @schema.@cm_table_prefixdiagnostics_summary cmds on cmds.analysis_id = cmr.analysis_id; - " - - - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - database_table = resultDatabaseSettings$databaseTable - ) - ) -} - - -getCohortMethodMainResults <- function( - connectionHandler, - resultDatabaseSettings, - targetIds = c(), - comparatorIds = c(), - outcomeIds = c(), - databaseIds = c(), - analysisIds = c() -) { - - sql <- " -SELECT - cma.analysis_id, - cma.description description, - dmd.database_id database_id, -- break? - dmd.cdm_source_abbreviation cdm_source_abbreviation, - cmr.rr rr, - cmr.ci_95_lb ci_95_lb, - cmr.ci_95_ub ci_95_ub, - cmr.p p, - cmr.log_rr, - cmr.se_log_rr, - cmr.target_subjects, - cmr.comparator_subjects, - cmr.target_days, - cmr.comparator_days, - cmr.target_outcomes, - cmr.comparator_outcomes, - cmr.calibrated_rr calibrated_rr, - cmr.calibrated_ci_95_lb calibrated_ci_95_lb, - cmr.calibrated_ci_95_ub calibrated_ci_95_ub, - cmr.calibrated_p calibrated_p, - cmr.calibrated_log_rr, - cmr.calibrated_se_log_rr, - COALESCE(cmds.unblind, 0) unblind -- TODO: assume unblinded? (or always populated and moot) -FROM - @schema.@cm_table_prefixanalysis cma - JOIN @schema.@cm_table_prefixresult cmr - on cmr.analysis_id = cma.analysis_id - - JOIN @schema.@database_table dmd - on dmd.database_id = cmr.database_id - - LEFT JOIN @schema.@cm_table_prefixdiagnostics_summary cmds - on cmds.analysis_id = cmr.analysis_id - AND cmds.target_id = cmr.target_id - AND cmds.comparator_id = cmr.comparator_id - AND cmds.outcome_id = cmr.outcome_id - AND cmds.database_id = cmr.database_id - " - if (length(targetIds) > 0 || - length(comparatorIds) > 0 || - length(outcomeIds) > 0 || - length(databaseIds) > 0 || - length(analysisIds) > 0) { - sql <- paste0(sql, "\nWHERE\n\t") - } - - clauses <- c() - if (length(targetIds) > 0 ) { - clauses <- c(clauses, "cmr.target_id IN (@target_ids)\n\t") - } - if (length(comparatorIds) > 0) { - clauses <- c(clauses, "cmr.comparator_id IN (@comparator_ids)\n\t") - } - if (length(outcomeIds) > 0) { - clauses <- c(clauses, "cmr.outcome_id IN (@outcome_ids)\n\t") - } - if (length(databaseIds) > 0) { - clauses <- c(clauses, "cmr.database_id IN (@database_ids)\n\t") - } - if (length(analysisIds) > 0) { - clauses <- c(clauses, "cmr.analysis_id IN (@analysis_ids)\n\t") - } - sql <- paste0(sql, paste(clauses, collapse = " AND "), ";") - return( - suppressWarnings( # ignoring warnings due to parameter not found - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - database_table = resultDatabaseSettings$databaseTable, - target_ids = paste0("'", paste(targetIds, collapse = "', '"), "'"), - comparator_ids = paste0("'", paste(comparatorIds, collapse = "', '"), "'"), - outcome_ids = paste0("'", paste(outcomeIds, collapse = "', '"), "'"), - database_ids = paste0("'", paste(databaseIds, collapse = "', '"), "'"), - analysis_ids = paste0("'", paste(analysisIds, collapse = "', '"), "'") - ) - ) - ) - -} - - -getCohortMethodAnalyses <- function( - connectionHandler, - resultDatabaseSettings - ) { - sql <- " - SELECT - cma.* - FROM - @schema.@cm_table_prefixanalysis cma - " - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix - ) - ) -} - - -getCohortMethodSubgroupResults <- function(connectionHandler, # not used? - targetIds = c(), - comparatorIds = c(), - outcomeIds = c(), - databaseIds = c(), - analysisIds = c(), - subgroupIds = c(), - estimatesOnly = FALSE, - cmInteractionResult = c(), # added to clean check - covariate = c() # added to clean check - ) { - idx <- rep(TRUE, nrow(cmInteractionResult)) - if (length(targetIds) != 0) { - idx <- idx & cmInteractionResult$targetId %in% targetIds - } - if (length(comparatorIds) != 0) { - idx <- idx & cmInteractionResult$comparatorId %in% comparatorIds - } - if (length(outcomeIds) != 0) { - idx <- idx & cmInteractionResult$outcomeId %in% outcomeIds - } - if (length(databaseIds) != 0) { - idx <- idx & cmInteractionResult$databaseId %in% databaseIds - } - if (length(analysisIds) != 0) { - idx <- idx & cmInteractionResult$analysisId %in% analysisIds - } - if (length(subgroupIds) != 0) { - idx <- idx & cmInteractionResult$interactionCovariateId %in% subgroupIds - } - result <- cmInteractionResult[idx, ] - result <- merge(result, data.frame(interactionCovariateId = covariate$covariateId, - databaseId = covariate$databaseId, - covariateName = covariate$covariateName)) - result <- result[, c("covariateName", - "targetSubjects", - "comparatorSubjects", - "rrr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedP")] - colnames(result) <- c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "rrr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedP") - return(result) -} - - -getCohortMethodControlResults <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - analysisId, - databaseId = NULL, - includePositiveControls = TRUE, - emptyAsNa = TRUE - ) { - - sql <- " - SELECT - cmr.*, - cmtco.true_effect_size effect_size - FROM - @schema.@cm_table_prefixresult cmr - JOIN @schema.@cm_table_prefixtarget_comparator_outcome cmtco - ON cmr.target_id = cmtco.target_id AND cmr.comparator_id = cmtco.comparator_id AND cmr.outcome_id = cmtco.outcome_id - WHERE - cmtco.outcome_of_interest != 1 - AND cmr.target_id = @target_id - AND cmr.comparator_id = @comparator_id - AND cmr.analysis_id = @analysis_id - " - - - if (!is.null(databaseId)) { - # update sql - sql <- paste(sql, paste("AND cmr.database_id = '@database_id'"), collapse = "\n") - } - - if (!includePositiveControls) { - # update sql - sql <- paste(sql, paste("AND cmtco.true_effect_size = 1"), collapse = "\n") - } - - results <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - - if (emptyAsNa) { - results[results == ''] <- NA - } - - return(results) -} - - -getCmFollowUpDist <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - outcomeId, - databaseId = NULL, - analysisId -) { - - sql <- " - SELECT - * - FROM - @schema.@cm_table_prefixfollow_up_dist cmfud - WHERE - cmfud.target_id = @target_id - AND cmfud.comparator_id = @comparator_id - AND cmfud.outcome_id = @outcome_id - AND cmfud.analysis_id = @analysis_id - " - if(!is.null(databaseId)) { - sql <- paste(sql, paste("AND cmfud.database_id = '@database_id'"), collapse = "\n") - } - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - ) -} - - -getCohortMethodPs <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - analysisId, - databaseId = NULL - ) { - sql <- " - SELECT - * - FROM - @schema.@cm_table_prefixpreference_score_dist cmpsd - WHERE - cmpsd.target_id = @target_id - AND cmpsd.comparator_id = @comparator_id - AND cmpsd.analysis_id = @analysis_id - " - if(!is.null(databaseId)) { - sql <- paste(sql, paste("AND cmpsd.database_id = '@database_id'"), collapse = "\n") - } - - - ps <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - - - if (!is.null(databaseId)) { - ps$databaseId <- NULL - } - return(ps) -} - - -getCohortMethodKaplanMeier <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - outcomeId, - databaseId, - analysisId - ) { - - sql <- " - SELECT - * - FROM - @schema.@cm_table_prefixkaplan_meier_dist cmkmd - WHERE - cmkmd.target_id = @target_id - AND cmkmd.comparator_id = @comparator_id - AND cmkmd.outcome_id = @outcome_id - AND cmkmd.analysis_id = @analysis_id - AND cmkmd.database_id = '@database_id'; - " - - return( - connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - #database_table = resultDatabaseSettings$databaseTable, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - ) -} - - -getCohortMethodAttrition <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - outcomeId, - analysisId, - databaseId - ) { - - sql <- " - SELECT cmat.* - FROM - @schema.@cm_table_prefixattrition cmat - WHERE - cmat.target_id = @target_id - AND cmat.comparator_id = @comparator_id - AND cmat.outcome_id = @outcome_id - AND cmat.analysis_id = @analysis_id - AND cmat.database_id = '@database_id'; - " - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - #database_table = resultDatabaseSettings$databaseTable, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - targetAttrition <- result[result$exposureId == targetId, ] - comparatorAttrition <- result[result$exposureId == comparatorId, ] - colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons" - targetAttrition$exposureId <- NULL - colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons" - comparatorAttrition$exposureId <- NULL - result <- merge(targetAttrition, comparatorAttrition) - result <- result[order(result$sequenceNumber), ] - return(result) -} - - -getCohortMethodStudyPeriod <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - databaseId - ) { - sql <- "SELECT min_date, max_date - FROM @schema.@cm_table_prefixcomparison_summary - WHERE target_id = @target_id - AND comparator_id = @comparator_id - AND database_id = '@database_id';" - - studyPeriod <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - target_id = targetId, - comparator_id = comparatorId, - database_id = databaseId - ) - return(studyPeriod) -} - - -getCohortMethodPropensityModel <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - analysisId, - databaseId - ) { - sqlTmp <- " - SELECT - cmpm.coefficient, - cmc.covariate_id, - cmc.covariate_name - FROM - @schema.@cm_table_prefixcovariate cmc - JOIN @schema.@cm_table_prefixpropensity_model cmpm - ON cmc.covariate_id = cmpm.covariate_id - AND cmc.database_id = cmpm.database_id - WHERE - cmpm.target_id = @target_id - AND cmpm.comparator_id = @comparator_id - AND cmpm.analysis_id = @analysis_id - AND cmpm.database_id = '@database_id' - " - - sql <- " - SELECT - cmc.covariate_id, - cmc.covariate_name, - cmpm.coefficient - FROM - ( - SELECT - covariate_id, - covariate_name - FROM - @schema.@cm_table_prefixcovariate - WHERE - analysis_id = @analysis_id - AND database_id = '@database_id' - UNION - SELECT - 0 as covariate_id, - 'intercept' as covariate_name) cmc - JOIN @schema.@cm_table_prefixpropensity_model cmpm - ON cmc.covariate_id = cmpm.covariate_id - WHERE - cmpm.target_id = @target_id - AND cmpm.comparator_id = @comparator_id - AND cmpm.analysis_id = @analysis_id - AND cmpm.database_id = '@database_id' - " - - model <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - return(model) -} - - - - -getCohortMethodNegativeControlEstimates <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - comparatorId, - analysisId - ) { - - subset <- getCohortMethodControlResults( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = targetId, - comparatorId =comparatorId, - analysisId = analysisId, - includePositiveControls = FALSE - ) - subset <- subset[, c("databaseId", "logRr", "seLogRr")] - if(nrow(subset) == 0) - return(NULL) - return(subset) -} - - - - diff --git a/R/helpers-cohort-methodPlotsAndTables.R b/R/helpers-cohort-methodPlotsAndTables.R deleted file mode 100644 index e7a5122c..00000000 --- a/R/helpers-cohort-methodPlotsAndTables.R +++ /dev/null @@ -1,621 +0,0 @@ -# used in estimation-power -prepareCohortMethodFollowUpDistTable <- function(followUpDist) { - targetRow <- data.frame(Database = followUpDist$databaseId, - Cohort = "Target", - Min = followUpDist$targetMinDays, - P10 = followUpDist$targetP10Days, - P25 = followUpDist$targetP25Days, - Median = followUpDist$targetMedianDays, - P75 = followUpDist$targetP75Days, - P90 = followUpDist$targetP90Days, - Max = followUpDist$targetMaxDays) - comparatorRow <- data.frame(Database = followUpDist$databaseId, - Cohort = "Comparator", - Min = followUpDist$comparatorMinDays, - P10 = followUpDist$comparatorP10Days, - P25 = followUpDist$comparatorP25Days, - Median = followUpDist$comparatorMedianDays, - P75 = followUpDist$comparatorP75Days, - P90 = followUpDist$comparatorP90Days, - Max = followUpDist$comparatorMaxDays) - table <- rbind(targetRow, comparatorRow) - table$Min <- formatC(table$Min, big.mark = ",", format = "d") - table$P10 <- formatC(table$P10, big.mark = ",", format = "d") - table$P25 <- formatC(table$P25, big.mark = ",", format = "d") - table$Median <- formatC(table$Median, big.mark = ",", format = "d") - table$P75 <- formatC(table$P75, big.mark = ",", format = "d") - table$P90 <- formatC(table$P90, big.mark = ",", format = "d") - table$Max <- formatC(table$Max, big.mark = ",", format = "d") - if (length(unique(followUpDist$databaseId)) == 1) - table$Database <- NULL - return(table) -} - - -# used in estimation-power -prepareCohortMethodPowerTable <- function( - mainResults, - connectionHandler , - resultDatabaseSettings - ) { - analyses <- getCohortMethodAnalyses( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - table <- merge(mainResults, analyses) - alpha <- 0.05 - power <- 0.8 - z1MinAlpha <- stats::qnorm(1 - alpha/2) - zBeta <- -stats::qnorm(1 - power) - pA <- table$targetSubjects/(table$targetSubjects + table$comparatorSubjects) - pB <- 1 - pA - totalEvents <- abs(table$targetOutcomes) + abs(table$comparatorOutcomes) - table$mdrr <- exp(sqrt((zBeta + z1MinAlpha)^2/(totalEvents * pA * pB))) - table$targetYears <- table$targetDays/365.25 - table$comparatorYears <- table$comparatorDays/365.25 - table$targetIr <- 1000 * table$targetOutcomes/table$targetYears - table$comparatorIr <- 1000 * table$comparatorOutcomes/table$comparatorYears - table <- table[, c("description", - "databaseId", - "targetSubjects", - "comparatorSubjects", - "targetYears", - "comparatorYears", - "targetOutcomes", - "comparatorOutcomes", - "targetIr", - "comparatorIr", - "mdrr")] - table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") - table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") - table$targetYears <- formatC(table$targetYears, big.mark = ",", format = "d") - table$comparatorYears <- formatC(table$comparatorYears, big.mark = ",", format = "d") - table$targetOutcomes <- formatC(table$targetOutcomes, big.mark = ",", format = "d") - table$comparatorOutcomes <- formatC(table$comparatorOutcomes, big.mark = ",", format = "d") - table$targetIr <- sprintf("%.2f", table$targetIr) - table$comparatorIr <- sprintf("%.2f", table$comparatorIr) - table$mdrr <- sprintf("%.2f", table$mdrr) - table$targetSubjects <- gsub("^-", "<", table$targetSubjects) - table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) - table$targetOutcomes <- gsub("^-", "<", table$targetOutcomes) - table$comparatorOutcomes <- gsub("^-", "<", table$comparatorOutcomes) - table$targetIr <- gsub("^-", "<", table$targetIr) - table$comparatorIr <- gsub("^-", "<", table$comparatorIr) - idx <- (table$targetOutcomes < 0 | table$comparatorOutcomes < 0) - table$mdrr[idx] <- paste0(">", table$mdrr[idx]) - return(table) -} - -# estimation-subgroups -prepareCohortMethodSubgroupTable <- function(subgroupResults, output = "latex") { - rnd <- function(x) { - ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) - } - - subgroupResults$hrr <- paste0(rnd(subgroupResults$rrr), - " (", - rnd(subgroupResults$ci95Lb), - " - ", - rnd(subgroupResults$ci95Ub), - ")") - - subgroupResults$hrr[is.na(subgroupResults$rrr)] <- "" - subgroupResults$p <- sprintf("%.2f", subgroupResults$p) - subgroupResults$p[subgroupResults$p == "NA"] <- "" - subgroupResults$calibratedP <- sprintf("%.2f", subgroupResults$calibratedP) - subgroupResults$calibratedP[subgroupResults$calibratedP == "NA"] <- "" - - if (any(grepl("on-treatment", subgroupResults$analysisDescription)) && - any(grepl("intent-to-treat", subgroupResults$analysisDescription))) { - idx <- grepl("on-treatment", subgroupResults$analysisDescription) - onTreatment <- subgroupResults[idx, c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "hrr", - "p", - "calibratedP")] - itt <- subgroupResults[!idx, c("interactionCovariateName", "hrr", "p", "calibratedP")] - colnames(onTreatment)[4:6] <- paste("onTreatment", colnames(onTreatment)[4:6], sep = "_") - colnames(itt)[2:4] <- paste("itt", colnames(itt)[2:4], sep = "_") - table <- merge(onTreatment, itt) - } else { - table <- subgroupResults[, c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "hrr", - "p", - "calibratedP")] - } - table$interactionCovariateName <- gsub("Subgroup: ", "", table$interactionCovariateName) - if (output == "latex") { - table$interactionCovariateName <- gsub(">=", "$\\\\ge$ ", table$interactionCovariateName) - } - table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") - table$targetSubjects <- gsub("^-", "<", table$targetSubjects) - table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") - table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) - table$comparatorSubjects <- gsub("^<", "$<$", table$comparatorSubjects) - return(table) -} - - - - - - -# estiamtion-covariateBal -plotCohortMethodCovariateBalanceSummary <- function(balanceSummary, - threshold = 0, - beforeLabel = "Before matching", - afterLabel = "After matching") { - balanceSummary <- balanceSummary[rev(order(balanceSummary$databaseId)), ] - dbs <- data.frame(databaseId = unique(balanceSummary$databaseId), - x = 1:length(unique(balanceSummary$databaseId))) - vizData <- merge(balanceSummary, dbs) - - vizData$type <- factor(vizData$type, levels = c(beforeLabel, afterLabel)) - - plot <- ggplot2::ggplot(vizData, ggplot2::aes(x = .data$x, - ymin = .data$ymin, - lower = .data$lower, - middle = .data$median, - upper = .data$upper, - ymax = .data$ymax, - group = .data$databaseId)) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) + - ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) + - ggplot2::geom_hline(yintercept = 0) + - ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) + - ggplot2::scale_y_continuous("Standardized difference of mean") + - ggplot2::coord_flip() + - ggplot2::facet_grid(~type) + - ggplot2::theme(panel.grid.major.y = ggplot2::element_blank(), - panel.grid.minor.y = ggplot2::element_blank(), - panel.grid.major.x = ggplot2::element_line(color = "#AAAAAA"), - panel.background = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(size = 11), - axis.title.x = ggplot2::element_text(size = 11), - axis.ticks.x = ggplot2::element_line(color = "#AAAAAA"), - strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(size = 11), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) - - if (threshold != 0) { - plot <- plot + ggplot2::geom_hline(yintercept = c(threshold, -threshold), linetype = "dotted") - } - after <- vizData[vizData$type == afterLabel, ] - after$max <- pmax(abs(after$ymin), abs(after$ymax)) - text <- data.frame(y = rep(c(after$x, nrow(after) + 1.25) , 3), - x = rep(c(1,2,3), each = nrow(after) + 1), - label = c(c(as.character(after$databaseId), - "Source", - formatC(after$covariateCount, big.mark = ",", format = "d"), - "Covariate\ncount", - formatC(after$max, digits = 2, format = "f"), - paste(afterLabel, "max(absolute)", sep = "\n"))), - dummy = "") - - data_table <- ggplot2::ggplot(text, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + - ggplot2::geom_text(size = 4, hjust=0, vjust=0.5) + - ggplot2::geom_hline(ggplot2::aes(yintercept=nrow(after) + 0.5)) + - ggplot2::theme(panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(colour="white"), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_line(colour="white"), - strip.background = ggplot2::element_blank(), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + - ggplot2::labs(x="",y="") + - ggplot2::facet_grid(~dummy) + - ggplot2::coord_cartesian(xlim=c(1,4), ylim = c(0.5, max(vizData$x) + 1.75)) - - plot <- gridExtra::grid.arrange(data_table, plot, ncol = 2) - return(plot) -} - -# estimation-systematicError -plotCohortMethodScatter <- function(controlResults) { - - if(nrow(controlResults)==0){ - return(NULL) - } - - size <- 2 - labelY <- 0.7 - d <- rbind(data.frame(yGroup = "Uncalibrated", - logRr = controlResults$logRr, - seLogRr = controlResults$seLogRr, - ci95Lb = controlResults$ci95Lb, - ci95Ub = controlResults$ci95Ub, - trueRr = controlResults$effectSize), - data.frame(yGroup = "Calibrated", - logRr = controlResults$calibratedLogRr, - seLogRr = controlResults$calibratedSeLogRr, - ci95Lb = controlResults$calibratedCi95Lb, - ci95Ub = controlResults$calibratedCi95Ub, - trueRr = controlResults$effectSize)) - d <- d[!is.na(d$logRr), ] - d <- d[!is.na(d$ci95Lb), ] - d <- d[!is.na(d$ci95Ub), ] - if (nrow(d) == 0) { - return(NULL) - } - d$Group <- as.factor(d$trueRr) - d$Significant <- d$ci95Lb > d$trueRr | d$ci95Ub < d$trueRr - temp1 <- stats::aggregate(Significant ~ Group + yGroup, data = d, length) - temp2 <- stats::aggregate(Significant ~ Group + yGroup, data = d, mean) - temp1$nLabel <- paste0(formatC(temp1$Significant, big.mark = ","), " estimates") - temp1$Significant <- NULL - - temp2$meanLabel <- paste0(formatC(100 * (1 - temp2$Significant), digits = 1, format = "f"), - "% of CIs include ", - temp2$Group) - temp2$Significant <- NULL - dd <- merge(temp1, temp2) - dd$tes <- as.numeric(as.character(dd$Group)) - - breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) - theme <- ggplot2::element_text(colour = "#000000", size = 12) - themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) - themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) - - d$Group <- paste("True hazard ratio =", d$Group) - dd$Group <- paste("True hazard ratio =", dd$Group) - alpha <- 1 - min(0.95 * (nrow(d)/nrow(dd)/50000)^0.1, 0.95) - plot <- ggplot2::ggplot(d, ggplot2::aes(x = .data$logRr, y = .data$seLogRr), environment = environment()) + - ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + - ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.025), slope = 1/stats::qnorm(0.025)), - colour = grDevices::rgb(0.8, 0, 0), - linetype = "dashed", - size = 1, - alpha = 0.5, - data = dd) + - ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.975), slope = 1/stats::qnorm(0.975)), - colour = grDevices::rgb(0.8, 0, 0), - linetype = "dashed", - size = 1, - alpha = 0.5, - data = dd) + - ggplot2::geom_point(size = size, - color = grDevices::rgb(0, 0, 0, alpha = 0.05), - alpha = alpha, - shape = 16) + - ggplot2::geom_hline(yintercept = 0) + - ggplot2::geom_label(x = log(0.15), - y = 0.9, - alpha = 1, - hjust = "left", - ggplot2::aes(label = .data$nLabel), - size = 5, - data = dd) + - ggplot2::geom_label(x = log(0.15), - y = labelY, - alpha = 1, - hjust = "left", - ggplot2::aes(label = .data$meanLabel), - size = 5, - data = dd) + - ggplot2::scale_x_continuous("Hazard ratio", - limits = log(c(0.1, 10)), - breaks = log(breaks), - labels = breaks) + - ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + - ggplot2::facet_grid(yGroup ~ Group) + - ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - axis.text.y = themeRA, - axis.text.x = theme, - axis.title = theme, - legend.key = ggplot2::element_blank(), - strip.text.x = theme, - strip.text.y = theme, - strip.background = ggplot2::element_blank(), - legend.position = "none") - - return(plot) -} - -# estimation-attrition -drawCohortMethodAttritionDiagram <- function(attrition, - targetLabel = "Target", - comparatorLabel = "Comparator") { - addStep <- function(data, attrition, row) { - label <- paste(strwrap(as.character(attrition$description[row]), width = 30), collapse = "\n") - data$leftBoxText[length(data$leftBoxText) + 1] <- label - data$rightBoxText[length(data$rightBoxText) + 1] <- paste(targetLabel, - ": n = ", - data$currentTarget - attrition$targetPersons[row], - "\n", - comparatorLabel, - ": n = ", - data$currentComparator - attrition$comparatorPersons[row], - sep = "") - data$currentTarget <- attrition$targetPersons[row] - data$currentComparator <- attrition$comparatorPersons[row] - return(data) - } - data <- list(leftBoxText = c(paste("Exposed:\n", - targetLabel, - ": n = ", - attrition$targetPersons[1], - "\n", - comparatorLabel, - ": n = ", - attrition$comparatorPersons[1], - sep = "")), rightBoxText = c(""), currentTarget = attrition$targetPersons[1], currentComparator = attrition$comparatorPersons[1]) - for (i in 2:nrow(attrition)) { - data <- addStep(data, attrition, i) - } - - - data$leftBoxText[length(data$leftBoxText) + 1] <- paste("Study population:\n", - targetLabel, - ": n = ", - data$currentTarget, - "\n", - comparatorLabel, - ": n = ", - data$currentComparator, - sep = "") - leftBoxText <- data$leftBoxText - rightBoxText <- data$rightBoxText - nSteps <- length(leftBoxText) - - boxHeight <- (1/nSteps) - 0.03 - boxWidth <- 0.45 - shadowOffset <- 0.01 - arrowLength <- 0.01 - x <- function(x) { - return(0.25 + ((x - 1)/2)) - } - y <- function(y) { - return(1 - (y - 0.5) * (1/nSteps)) - } - - downArrow <- function(p, x1, y1, x2, y2) { - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 + arrowLength, - yend = y2 + arrowLength)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 + arrowLength)) - return(p) - } - rightArrow <- function(p, x1, y1, x2, y2) { - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 + arrowLength)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 - arrowLength)) - return(p) - } - box <- function(p, x, y) { - p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2) + shadowOffset, - ymin = y - (boxHeight/2) - shadowOffset, - xmax = x + (boxWidth/2) + shadowOffset, - ymax = y + (boxHeight/2) - shadowOffset), fill = grDevices::rgb(0, - 0, - 0, - alpha = 0.2)) - p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2), - ymin = y - (boxHeight/2), - xmax = x + (boxWidth/2), - ymax = y + (boxHeight/2)), fill = grDevices::rgb(0.94, - 0.94, - 0.94), color = "black") - return(p) - } - label <- function(p, x, y, text, hjust = 0) { - p <- p + ggplot2::geom_text(ggplot2::aes_string(x = x, y = y, label = paste("\"", text, "\"", - sep = "")), - hjust = hjust, - size = 3.7) - return(p) - } - - p <- ggplot2::ggplot() - for (i in 2:nSteps - 1) { - p <- downArrow(p, x(1), y(i) - (boxHeight/2), x(1), y(i + 1) + (boxHeight/2)) - p <- label(p, x(1) + 0.02, y(i + 0.5), "Y") - } - for (i in 2:(nSteps - 1)) { - p <- rightArrow(p, x(1) + boxWidth/2, y(i), x(2) - boxWidth/2, y(i)) - p <- label(p, x(1.5), y(i) - 0.02, "N", 0.5) - } - for (i in 1:nSteps) { - p <- box(p, x(1), y(i)) - } - for (i in 2:(nSteps - 1)) { - p <- box(p, x(2), y(i)) - } - for (i in 1:nSteps) { - p <- label(p, x(1) - boxWidth/2 + 0.02, y(i), text = leftBoxText[i]) - } - for (i in 2:(nSteps - 1)) { - p <- label(p, x(2) - boxWidth/2 + 0.02, y(i), text = rightBoxText[i]) - } - p <- p + ggplot2::theme(legend.position = "none", - plot.background = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text = ggplot2::element_blank(), - axis.title = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank()) - - return(p) -} - -# used in helpers-estPandT -nonZeroCohortMethodHazardRatio <- function(hrLower, hrUpper, terms) { - if (hrUpper < 1) { - return(terms[1]) - } else if (hrLower > 1) { - return(terms[2]) - } else { - return(terms[3]) - } -} - -# estimation-resultsTable -prettyCohortMethodHr <- function(x) { - if (!is.numeric(x)) { - x <- as.numeric(x) - } - result <- sprintf("%.2f", x) - result[is.na(x) | x > 100] <- "NA" - return(result) -} - -# used in here -goodCohortMethodPropensityScore <- function(value) { - return(value > 1) -} - -# used in here -goodCohortMethodSystematicBias <- function(value) { - return(value > 1) -} - - -# estmation-propensity -prepareCohortMethodPropensityModelTable <- function(model) { - rnd <- function(x) { - ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) - } - table <- model[order(-abs(model$coefficient)), c("coefficient", "covariateName")] - table$coefficient <- sprintf("%.2f", table$coefficient) - colnames(table) <- c("Beta", "Covariate") - return(table) -} - -# estimation-forestPlot -plotCohortMethodForest <- function(results, limits = c(0.1, 10), metaAnalysisDbIds = NULL) { - - dbResults <- results[!(results$databaseId %in% metaAnalysisDbIds), ] - dbResults <- dbResults[!is.na(dbResults$seLogRr), ] - dbResults <- dbResults[order(dbResults$databaseId), ] - maResult <- results[results$databaseId %in% metaAnalysisDbIds, ] - summaryLabel <- sprintf("Summary (I\u00B2 = %.2f)", as.numeric(maResult$i2)) - d1 <- data.frame(x = "Uncalibrated", - logRr = -100, - logLb95Ci = -100, - logUb95Ci = -100, - name = "Source", - type = "header", - stringsAsFactors = FALSE) - d2 <- data.frame(x = "Uncalibrated", - logRr = dbResults$logRr, - logLb95Ci = log(dbResults$ci95Lb), - logUb95Ci = log(dbResults$ci95Ub), - name = dbResults$databaseId, - type = "db", - stringsAsFactors = FALSE) - d3 <- data.frame(x = "Uncalibrated", - logRr = maResult$logRr, - logLb95Ci = log(maResult$ci95Lb), - logUb95Ci = log(maResult$ci95Ub), - name = summaryLabel, - type = "ma", - stringsAsFactors = FALSE) - d4 <- data.frame(x = "Calibrated", - logRr = -100, - logLb95Ci = -100, - logUb95Ci = -100, - name = "Source", - type = "header", - stringsAsFactors = FALSE) - d5 <- data.frame(x = "Calibrated", - logRr = dbResults$calibratedLogRr, - logLb95Ci = log(dbResults$calibratedCi95Lb), - logUb95Ci = log(dbResults$calibratedCi95Ub), - name = dbResults$databaseId, - type = "db", - stringsAsFactors = FALSE) - d6 <- data.frame(x = "Calibrated", - logRr = maResult$calibratedLogRr, - logLb95Ci = log(maResult$calibratedCi95Lb), - logUb95Ci = log(maResult$calibratedCi95Ub), - name = summaryLabel, - type = "ma", - stringsAsFactors = FALSE) - - d <- rbind(d1, d2, d3, d4, d5, d6) - d$name <- factor(d$name, levels = c(summaryLabel, rev(as.character(dbResults$databaseId)), "Source")) - d$x <- factor(d$x, levels = c("Uncalibrated", "Calibrated")) - - breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) - plot <- ggplot2::ggplot(d,ggplot2::aes(x = exp(.data$logRr), y = .data$name, xmin = exp(.data$logLb95Ci), xmax = exp(.data$logUb95Ci))) + - ggplot2::geom_vline(xintercept = breaks, colour = "#AAAAAA", lty = 1, size = 0.2) + - ggplot2::geom_vline(xintercept = 1, size = 0.5) + - ggplot2::geom_errorbarh(height = 0.15) + - ggplot2::geom_point(size=3, shape = 23, ggplot2::aes(fill=.data$type)) + - ggplot2::scale_fill_manual(values = c("#000000", "#000000", "#FFFFFF")) + - ggplot2::scale_x_continuous("Hazard ratio", trans = "log10", breaks = breaks, labels = breaks) + - ggplot2::coord_cartesian(xlim = limits) + - ggplot2::facet_grid(~ x) + - ggplot2::theme(text = ggplot2::element_text(size = 18), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - strip.background = ggplot2::element_blank(), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) - - d$hr <- paste0(formatC(exp(d$logRr), digits = 2, format = "f"), - " (", - formatC(exp(d$logLb95Ci), digits = 2, format = "f"), - "-", - formatC(exp(d$logUb95Ci), digits = 2, format = "f"), - ")") - d <- d[order(d$x), ] - - labels <- data.frame(y = factor(c(as.character(d$name[d$x == "Uncalibrated"]), as.character(d$name)), levels = levels(d$name)), - x = rep(1:3, each = nrow(d)/2), - label = c(as.character(d$name[d$x == "Uncalibrated"]), d$hr), - dummy = "dummy", - stringsAsFactors = FALSE) - labels$label[nrow(d)/2 + 1] <- paste("HR (95% CI)") - labels$label[nrow(d) + 1] <- paste("Calibrated HR (95% CI)") - dataTable <- ggplot2::ggplot(labels, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + - ggplot2::geom_text(size = 5, hjust = 0, vjust = 0.5) + - ggplot2::geom_hline(ggplot2::aes(yintercept = nrow(d) - 0.5)) + - ggplot2::facet_grid(~dummy) + - ggplot2::theme(text = ggplot2::element_text(size = 18), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(colour = "white"), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_line(colour = "white"), - strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(colour = "white"), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + - ggplot2::labs(x = "", y = "") + - ggplot2::coord_cartesian(xlim = c(1,4)) - plot <- gridExtra::grid.arrange(dataTable, plot, ncol = 2) - return(plot) -} diff --git a/R/helpers-getCohortMethodUtility.R b/R/helpers-getCohortMethodUtility.R deleted file mode 100644 index a2276592..00000000 --- a/R/helpers-getCohortMethodUtility.R +++ /dev/null @@ -1,26 +0,0 @@ - -getCohortMethodColumnsToBlind <- function(results) { - columnsToBlind <- c("rr", "ci95Ub", "ci95Lb", - "logRr", "seLogRr", "p", - "calibratedRr", "calibratedCi95Ub", - "calibratedCi95Lb", "calibratedLogRr", - "calibratedSeLogRr", - "calibratedP") - - return(intersect(columnsToBlind, colnames(results))) - -} - -getCohortMethodSelectNamedChoices <- function(v1, v2) { - l <- as.list(v1) - names(l) <- as.vector(v2) - return(l) -} - - -filterCohortMethodEmptyNullValues <- function(v, includeNull=TRUE) { - valsToFilter <- c('') - if (includeNull) - valsToFilter <- c(valsToFilter, NULL) - return(v[! v %in% valsToFilter]) -} diff --git a/R/patient-level-prediction-covariateSummary.R b/R/patient-level-prediction-covariateSummary.R index a321a801..06acb5c0 100644 --- a/R/patient-level-prediction-covariateSummary.R +++ b/R/patient-level-prediction-covariateSummary.R @@ -175,8 +175,7 @@ patientLevelPredictionCovariateSummaryServer <- function( ) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) diff --git a/R/patient-level-prediction-designSummary.R b/R/patient-level-prediction-designSummary.R index f88b90d5..72861356 100644 --- a/R/patient-level-prediction-designSummary.R +++ b/R/patient-level-prediction-designSummary.R @@ -380,10 +380,10 @@ getPredictionDesignSummary <- function( dplyr::relocate("devDatabases", .before = "valDatabases") %>% dplyr::relocate("diagDatabases", .before = "devDatabases") - summaryTable <- cbind( - actions = rep("",nrow(summaryTable)), - summaryTable - ) + ##summaryTable <- cbind( + ## actions = rep("",nrow(summaryTable)), + ## summaryTable + ##) shiny::incProgress(3/3, detail = paste("Finished")) diff --git a/R/patient-level-prediction-diagnostics.R b/R/patient-level-prediction-diagnostics.R index ff388595..3755264e 100644 --- a/R/patient-level-prediction-diagnostics.R +++ b/R/patient-level-prediction-diagnostics.R @@ -31,11 +31,29 @@ patientLevelPredictionDiagnosticsViewer <- function(id) { ns <- shiny::NS(id) - shiny::div( - reactable::reactableOutput(ns('diagnosticSummaryTable')), - shiny::uiOutput(ns('main')) + shiny::tagList( + shinydashboard::box( + collapsible = TRUE, + collapsed = TRUE, + title = "All Database Diagnostics For Selected Model Design", + width = "100%", + shiny::htmlTemplate(system.file("patient-level-prediction-www", "main-diagnosticsSummaryHelp.html", package = utils::packageName())) + ), + shinydashboard::box( + status = "warning", + width = "100%", + shiny::uiOutput(outputId = ns("diagnosticSummaryText")) + ), + shinydashboard::box( + width = "100%", + shiny::div( + resultTableViewer(ns('diagnosticSummaryTable')), + shiny::uiOutput(ns('main')) + ) + ) ) + } #' The module server for exploring prediction diagnostic results @@ -62,222 +80,190 @@ patientLevelPredictionDiagnosticsServer <- function( id, function(input, output, session) { - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - shiny::observe({ - if(!is.null(modelDesignId()) ){ - - diagnosticTable <- getPredictionDiagnostics( - modelDesignId = modelDesignId(), - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - # input tables - output$diagnosticSummaryTable <- reactable::renderReactable({ - reactable::reactable( - data = cbind( - diagnosticTable, - participants = rep("",nrow(diagnosticTable)), - predictors = rep("",nrow(diagnosticTable)), - outcomes = rep("",nrow(diagnosticTable)) - ), - columns = list( - '1.1' = reactable::colDef( - header = withTooltip( - "1.1", - "Participants: Were appropriate data sources used, e.g. cohort, RCT or nested case-control study data?" - ), - cell = reactable::JS(" + selectedModelDesign <- shiny::reactive( + getModelDesignInfo( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + modelDesignId = modelDesignId + ) + ) + output$diagnosticSummaryText <- shiny::renderUI(selectedModelDesign()) + + diagnosticTable <- shiny::reactive({ + getPredictionDiagnostics( + modelDesignId = modelDesignId(), + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + }) + + colDefsInput <- list( + '1.1' = reactable::colDef( + header = withTooltip( + "1.1", + "Participants: Were appropriate data sources used, e.g. cohort, RCT or nested case-control study data?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '1.2' = reactable::colDef( - header = withTooltip( - "1.2", - "Participants: Were all inclusions and exclusions of participants appropriate?" - ), - cell = reactable::JS(" + '1.2' = reactable::colDef( + header = withTooltip( + "1.2", + "Participants: Were all inclusions and exclusions of participants appropriate?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '2.1' = reactable::colDef( - header = withTooltip( - "2.1", - "Predictors: Were predictors defined and assessed in a similar way for all participants?" - ), - cell = reactable::JS(" + '2.1' = reactable::colDef( + header = withTooltip( + "2.1", + "Predictors: Were predictors defined and assessed in a similar way for all participants?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '2.2' = reactable::colDef( - header = withTooltip( - "2.2", - "Predictors: Were predictor assessments made without knowledge of outcome data?" - ), - cell = reactable::JS(" + '2.2' = reactable::colDef( + header = withTooltip( + "2.2", + "Predictors: Were predictor assessments made without knowledge of outcome data?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '2.3' = reactable::colDef( - header = withTooltip( - "2.3", - "Predictors: Are all predictors available at the time the model is intended to be used?" - ), - cell = reactable::JS(" + '2.3' = reactable::colDef( + header = withTooltip( + "2.3", + "Predictors: Are all predictors available at the time the model is intended to be used?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '3.4' = reactable::colDef( - header = withTooltip( - "3.4", - "Outcome: Was the outcome defined and determined in a similar way for all participants?" - ), - cell = reactable::JS(" + '3.4' = reactable::colDef( + header = withTooltip( + "3.4", + "Outcome: Was the outcome defined and determined in a similar way for all participants?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '3.6' = reactable::colDef( - header = withTooltip( - "3.6", - "Outcome: Was the time interval between predictor assessment and outcome determination appropriate?" - ), - cell = reactable::JS(" + '3.6' = reactable::colDef( + header = withTooltip( + "3.6", + "Outcome: Was the time interval between predictor assessment and outcome determination appropriate?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } ")), - '4.1' = reactable::colDef( - header = withTooltip( - "4.1", - "Design: Were there a reasonable number of participants with the outcome?" - ), - cell = reactable::JS(" + '4.1' = reactable::colDef( + header = withTooltip( + "4.1", + "Design: Were there a reasonable number of participants with the outcome?" + ), + cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} } - ")), - participants = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Participants") - ), - predictors = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Predictors") - ), - outcomes = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Outcomes") - ) - ), - - onClick = reactable::JS( - paste0( - "function(rowInfo, column) { - // Only handle click events on the 'details' column - if (column.id !== 'participants' & column.id !== 'predictors' & column.id !== 'outcomes') { - return - } - - // Display an alert dialog with details for the row - //window.alert('Details for row ' + rowInfo.index + ':\\n' + JSON.stringify(rowInfo.values, null, 2)) + ")) + ) + + modelTableOutputs <- resultTableServer( + id = "diagnosticSummaryTable", + df = diagnosticTable, + colDefsInput = colDefsInput, + addActions = c('participants','predictors', 'outcomes') + ) - // Send the click event to Shiny, which will be available in input$show_details - // Note that the row index starts at 0 in JavaScript, so we add 1 - if(column.id == 'participants'){ - Shiny.setInputValue('",session$ns('show_participants'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'predictors'){ - Shiny.setInputValue('",session$ns('show_predictors'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'outcomes'){ - Shiny.setInputValue('",session$ns('show_outcomes'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - }" - ) - - ) - ) - - }) # end reactable - - + # listen # PARTICIPANTS #============ - shiny::observeEvent( - input$show_participants, - { - participants <- getPredictionDiagnosticParticipants( - diagnosticId = diagnosticTable$diagnosticId[input$show_participants$index], - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - - output$participants <- reactable::renderReactable({ - reactable::reactable( - data = participants %>% - dplyr::filter(.data$parameter == ifelse(is.null(input$participantParameters), unique(participants$parameter)[1], input$participantParameters)) %>% - dplyr::select( - c( + shiny::observeEvent(modelTableOutputs$actionCount(), { + + if(modelTableOutputs$actionType() == 'participants'){ + { + participants <- getPredictionDiagnosticParticipants( + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + output$participants <- reactable::renderReactable({ + reactable::reactable( + data = participants %>% + dplyr::filter(.data$parameter == ifelse(is.null(input$participantParameters), unique(participants$parameter)[1], input$participantParameters)) %>% + dplyr::select( + c( "probastId", "paramvalue", "metric", "value" - ) - ) %>% - dplyr::mutate( - value = format(.data$value, nsmall = 2, ) - ) %>% - tidyr::pivot_wider( - names_from = "paramvalue", #.data$paramvalue, - values_from = "value" #.data$value ) - ) - }) - output$main <- shiny::renderUI({ - shiny::div( - shiny::selectInput( - inputId = session$ns('participantParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(participants$parameter) - ), - reactable::reactableOutput(session$ns('participants')) - ) - }) # renderUI - } - ) # end observed event - - - + ) %>% + dplyr::mutate( + value = format(.data$value, nsmall = 2, ) + ) %>% + tidyr::pivot_wider( + names_from = "paramvalue", #.data$paramvalue, + values_from = "value" #.data$value + ) + ) + }) + + + shiny::showModal( + shiny::modalDialog( + title = "Participant Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::selectInput( + inputId = session$ns('participantParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(participants$parameter) + ), + reactable::reactableOutput(session$ns('participants')) + ) + ), + size = "l", + easyClose = T + )) + + } + + } + }) + + # PREDICTOR #================== - shiny::observeEvent( - input$show_predictors, - { - + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'predictors'){ predTable <- getPredictionDiagnosticPredictors( - diagnosticId = diagnosticTable$diagnosticId[input$show_predictors$index], + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) @@ -327,33 +313,40 @@ patientLevelPredictionDiagnosticsServer <- function( ) }) - output$main <- shiny::renderUI({ - shiny::div( - shiny::p('Were predictor assessments made without knowledge of outcome data? (if outcome occur shortly after index this may be problematic)'), - shiny::p(''), - - shiny::selectInput( - inputId = session$ns('predictorParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(predTable$inputType) + + shiny::showModal( + shiny::modalDialog( + title = "Predictor Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::p('Were predictor assessments made without knowledge of outcome data? (if outcome occur shortly after index this may be problematic)'), + shiny::p(''), + + shiny::selectInput( + inputId = session$ns('predictorParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(predTable$inputType) + ), + + plotly::plotlyOutput(session$ns('predictorPlot')) + ) ), - - plotly::plotlyOutput(session$ns('predictorPlot')) - ) - - }) # renderUI + size = "l", + easyClose = T + )) + } - ) + }) # OUTCOME # ================= - shiny::observeEvent( - input$show_outcomes, - { - + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'outcomes'){ + outcomeTable <- getPredictionDiagnosticOutcomes( - diagnosticId = diagnosticTable$diagnosticId[input$show_outcomes$index], + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) @@ -384,29 +377,34 @@ patientLevelPredictionDiagnosticsServer <- function( ) }) - output$main <- shiny::renderUI({ - shiny::div( - shiny::p('Was the outcome determined appropriately? (Are age/sex/year/month trends expected?)'), - shiny::p(''), - - shiny::selectInput( - inputId = session$ns('outcomeParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(outcomeTable$aggregation) + + shiny::showModal( + shiny::modalDialog( + title = "Outcome Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::p('Was the outcome determined appropriately? (Are age/sex/year/month trends expected?)'), + shiny::p(''), + + shiny::selectInput( + inputId = session$ns('outcomeParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(outcomeTable$aggregation) + ), + + plotly::plotlyOutput(session$ns('outcomePlot')) + ) ), - - plotly::plotlyOutput(session$ns('outcomePlot')) - ) - - }) # renderUI + size = "l", + easyClose = T + )) + } - ) - - + }) - } # not null - }) # observe + } ) # server } diff --git a/R/patient-level-prediction-discrimination.R b/R/patient-level-prediction-discrimination.R index cddaa057..c457c451 100644 --- a/R/patient-level-prediction-discrimination.R +++ b/R/patient-level-prediction-discrimination.R @@ -202,10 +202,11 @@ patientLevelPredictionDiscriminationServer <- function( values_from = 'value' ) - cbind( - actions = rep('', nrow(data)), - data - ) + ##cbind( + ## actions = rep('', nrow(data)), + ## data + ## ) + data }) diff --git a/R/patient-level-prediction-main.R b/R/patient-level-prediction-main.R index dd13b674..5fd1191a 100644 --- a/R/patient-level-prediction-main.R +++ b/R/patient-level-prediction-main.R @@ -79,6 +79,17 @@ patientLevelPredictionViewer <- function(id=1) { patientLevelPredictionModelSummaryViewer(ns('modelSummaryTab')) ), + shiny::tabPanel( + "Diagnostic Summary", + shiny::actionButton( + inputId = ns("backToDesignSummaryD"), + label = "Back To Design Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + patientLevelPredictionDiagnosticsViewer(ns('diagnostics')) + ), + shiny::tabPanel( "Explore Selected Model", @@ -217,6 +228,14 @@ patientLevelPredictionServer <- function( ) }) + shiny::observeEvent(input$backToDesignSummaryD, { + shiny::updateTabsetPanel( + session = session, + inputId = 'allView', + selected = 'Model Designs Summary' + ) + }) + # keep a reactive variable tracking the active tab singleViewValue <- shiny::reactive({ input$singleView @@ -246,10 +265,8 @@ patientLevelPredictionServer <- function( shiny::observeEvent(designSummary$modelDesignId(), { modelDesignId(designSummary$modelDesignId()) if(!is.null(designSummary$modelDesignId())){ - #shiny::showTab(inputId = "allView", session = session, target = "Models Summary") shiny::updateTabsetPanel(session, "allView", selected = "Models Summary") - #shiny::hideTab(inputId = "allView", session = session, target = "Explore Selected Model") - } + } }) @@ -279,10 +296,8 @@ patientLevelPredictionServer <- function( performanceId(performance$performanceId()) developmentDatabaseId(performance$developmentDatabaseId()) if(!is.null(performance$performanceId())){ - #shiny::showTab(inputId = "allView", session = session, target = "Explore Selected Model") shiny::updateTabsetPanel(session, "allView", selected = "Explore Selected Model") - #shiny::hideTab(inputId = "allView", session = session, target = "Models Summary") - } + } # hide validation tab if non internal val if(performance$modelDevelopment() == 1){ @@ -299,11 +314,11 @@ patientLevelPredictionServer <- function( # ============================= # diagnostic viewer - show model diagnostic results shiny::observeEvent(designSummary$diagnosticId(), { - shiny::showModal(shiny::modalDialog( - title = "Diagnostic", - patientLevelPredictionDiagnosticsViewer(session$ns('diagnostics')) - )) + if(!is.null(designSummary$diagnosticId())){ + shiny::updateTabsetPanel(session, "allView", selected = "Diagnostic Summary") + } }) + patientLevelPredictionDiagnosticsServer( id = 'diagnostics', modelDesignId = designSummary$diagnosticId, diff --git a/R/patient-level-prediction-modelSummary.R b/R/patient-level-prediction-modelSummary.R index 78823a39..47b7f41e 100644 --- a/R/patient-level-prediction-modelSummary.R +++ b/R/patient-level-prediction-modelSummary.R @@ -185,8 +185,7 @@ patientLevelPredictionModelSummaryServer <- function( attrition() %>% dplyr::select(-c("performanceId", "outcomeId")) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE ) ) @@ -329,12 +328,12 @@ getModelDesignPerformanceSummary <- function( }) # adding actions column to left - summaryTable <- cbind( - actions = rep("", nrow(summaryTable)), - summaryTable - ) + ##summaryTable <- cbind( + ## actions = rep("", nrow(summaryTable)), + ## summaryTable + ##) - return(summaryTable[,c('actions','Dev', 'Val', 'T','O', 'modelDesignId', + return(summaryTable[,c('Dev', 'Val', 'T','O', 'modelDesignId', 'TAR', 'AUROC', 'AUPRC', 'T Size', 'O Count','Val (%)', 'O Incidence (%)', 'timeStamp', 'performanceId', 'developmentDatabaseId', 'modelDevelopment', 'type')]) diff --git a/R/patient-level-prediction-settings.R b/R/patient-level-prediction-settings.R index 8eba86fe..79f8de14 100644 --- a/R/patient-level-prediction-settings.R +++ b/R/patient-level-prediction-settings.R @@ -120,8 +120,7 @@ patientLevelPredictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Cohort description", shiny::p(modelDesign()$cohort$cohortJson), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) @@ -142,8 +141,7 @@ patientLevelPredictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Cohort description", shiny::p(modelDesign()$outcome$cohortJson), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -163,8 +161,7 @@ patientLevelPredictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Exclusions done during data extraction", shiny::p(modelDesign()$RestrictPlpData), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -190,8 +187,7 @@ patientLevelPredictionSettingsServer <- function( formatPopSettings(modelDesign()$populationSettings) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -215,8 +211,7 @@ patientLevelPredictionSettingsServer <- function( formatCovSettings(modelDesign()$covariateSettings) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -242,8 +237,7 @@ patientLevelPredictionSettingsServer <- function( formatModSettings(modelDesign()$modelSettings ) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -264,8 +258,7 @@ patientLevelPredictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$featureEngineeringSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -286,8 +279,7 @@ patientLevelPredictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$preprocessSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -308,8 +300,7 @@ patientLevelPredictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$splitSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -330,8 +321,7 @@ patientLevelPredictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$sampleSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) diff --git a/R/sccs-diagnosticsSummary.R b/R/sccs-diagnosticsSummary.R index e605cdc6..e538e51a 100644 --- a/R/sccs-diagnosticsSummary.R +++ b/R/sccs-diagnosticsSummary.R @@ -248,35 +248,13 @@ sccsDiagnosticsSummaryServer <- function( ) - # Summary table - customColDefs2 <- list( - databaseName = reactable::colDef( - header = withTooltip( - "Database", - "The database name" - ), - sticky = "left" - ), - target = reactable::colDef( - header = withTooltip( - "Target", - "The target cohort of interest " - ), - sticky = "left" - ), - covariateName = reactable::colDef( - header = withTooltip( - "Time Period", - "The time period of interest" - ), - sticky = "left" - ) - ) - resultTableServer( id = "diagnosticsSummaryTable", df = data2, - colDefsInput = styleColumns(customColDefs2, outcomeIds, analysisIds) + colDefsInput = getColDefsSccsDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) ) } @@ -471,3 +449,73 @@ getSccsAllDiagnosticsSummary <- function( return(result) } + + +getColDefsSccsDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ), + sticky = "left" + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + sticky = "left" + ), + covariateName = reactable::colDef( + header = withTooltip( + "Time Period", + "The time period of interest" + ), + sticky = "left" + ) + ) + + outcomes <- getSccsDiagOutcomes( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + analyses <- getSccsDiagAnalyses( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) + colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) + + styleList <- lapply( + colnameFormat, + FUN = function(x){ + reactable::colDef( + header = withTooltip( + substring(x,1,40), + x + ), + style = function(value) { + color <- 'orange' + if(is.na(value)){ + color <- 'black' + }else if(value == 'Pass'){ + color <- '#AFE1AF' + }else if(value == 'Fail'){ + color <- '#E97451' + } + list(background = color) + } + ) + } + ) + names(styleList) <- colnameFormat + result <- append(fixedColumns, styleList) + + return(result) +} diff --git a/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html b/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html new file mode 100644 index 00000000..0d6b4b88 --- /dev/null +++ b/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html @@ -0,0 +1,6 @@ +

This shows the model design diagnostic results for the selected model design across databases. These diagnostics are based on PROBAST.

+ +

+add details +

+ diff --git a/man/cohortMethodAttritionServer.Rd b/man/cohortMethodAttritionServer.Rd index e1bc5703..6e3444cc 100644 --- a/man/cohortMethodAttritionServer.Rd +++ b/man/cohortMethodAttritionServer.Rd @@ -7,7 +7,6 @@ cohortMethodAttritionServer( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) @@ -17,8 +16,6 @@ cohortMethodAttritionServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} diff --git a/man/cohortMethodCovariateBalanceServer.Rd b/man/cohortMethodCovariateBalanceServer.Rd index 785ec960..41a874bc 100644 --- a/man/cohortMethodCovariateBalanceServer.Rd +++ b/man/cohortMethodCovariateBalanceServer.Rd @@ -7,7 +7,6 @@ cohortMethodCovariateBalanceServer( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings, metaAnalysisDbIds = NULL @@ -18,8 +17,6 @@ cohortMethodCovariateBalanceServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} diff --git a/man/cohortMethodDiagnosticsSummaryServer.Rd b/man/cohortMethodDiagnosticsSummaryServer.Rd index 1d69da14..b9660fed 100644 --- a/man/cohortMethodDiagnosticsSummaryServer.Rd +++ b/man/cohortMethodDiagnosticsSummaryServer.Rd @@ -7,7 +7,8 @@ cohortMethodDiagnosticsSummaryServer( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + inputSelected ) } \arguments{ @@ -16,6 +17,8 @@ cohortMethodDiagnosticsSummaryServer( \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} + +\item{inputSelected}{The target id, comparator id, outcome id and analysis id selected by the user} } \value{ the PLE diagnostics summary results diff --git a/man/cohortMethodForestPlotServer.Rd b/man/cohortMethodForestPlotServer.Rd deleted file mode 100644 index 95455092..00000000 --- a/man/cohortMethodForestPlotServer.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-forestPlot.R -\name{cohortMethodForestPlotServer} -\alias{cohortMethodForestPlotServer} -\title{The module server for rendering the PLE multiple results forest plot} -\usage{ -cohortMethodForestPlotServer( - id, - connectionHandler, - selectedRow, - inputParams, - metaAnalysisDbIds = NULL, - resultDatabaseSettings -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{connection} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} - -\item{resultDatabaseSettings}{a list containing the result schema and prefixes} -} -\value{ -the PLE forest plot content server -} -\description{ -The module server for rendering the PLE multiple results forest plot -} diff --git a/man/cohortMethodForestPlotViewer.Rd b/man/cohortMethodForestPlotViewer.Rd deleted file mode 100644 index a8678a9e..00000000 --- a/man/cohortMethodForestPlotViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-forestPlot.R -\name{cohortMethodForestPlotViewer} -\alias{cohortMethodForestPlotViewer} -\title{The module viewer for rendering the PLE results forest plot} -\usage{ -cohortMethodForestPlotViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the cohort method forest plot -} -\description{ -The module viewer for rendering the PLE results forest plot -} diff --git a/man/cohortMethodKaplanMeierServer.Rd b/man/cohortMethodKaplanMeierServer.Rd index 2e52424c..0f3f3c4b 100644 --- a/man/cohortMethodKaplanMeierServer.Rd +++ b/man/cohortMethodKaplanMeierServer.Rd @@ -7,10 +7,8 @@ cohortMethodKaplanMeierServer( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) } \arguments{ @@ -18,13 +16,9 @@ cohortMethodKaplanMeierServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} } \value{ the PLE Kaplain Meier content server diff --git a/man/cohortMethodPopulationCharacteristicsServer.Rd b/man/cohortMethodPopulationCharacteristicsServer.Rd index 1e0deca2..34119408 100644 --- a/man/cohortMethodPopulationCharacteristicsServer.Rd +++ b/man/cohortMethodPopulationCharacteristicsServer.Rd @@ -7,7 +7,6 @@ cohortMethodPopulationCharacteristicsServer( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) @@ -17,8 +16,6 @@ cohortMethodPopulationCharacteristicsServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} diff --git a/man/cohortMethodPowerServer.Rd b/man/cohortMethodPowerServer.Rd index 023f8251..d9b9b201 100644 --- a/man/cohortMethodPowerServer.Rd +++ b/man/cohortMethodPowerServer.Rd @@ -7,10 +7,8 @@ cohortMethodPowerServer( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) } \arguments{ @@ -18,13 +16,9 @@ cohortMethodPowerServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} } \value{ the PLE systematic error power server diff --git a/man/cohortMethodPropensityModelServer.Rd b/man/cohortMethodPropensityModelServer.Rd index f0ce6248..1c0ab242 100644 --- a/man/cohortMethodPropensityModelServer.Rd +++ b/man/cohortMethodPropensityModelServer.Rd @@ -7,7 +7,6 @@ cohortMethodPropensityModelServer( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings ) @@ -17,8 +16,6 @@ cohortMethodPropensityModelServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} diff --git a/man/cohortMethodPropensityScoreDistServer.Rd b/man/cohortMethodPropensityScoreDistServer.Rd index 910cbb5d..a5b57e16 100644 --- a/man/cohortMethodPropensityScoreDistServer.Rd +++ b/man/cohortMethodPropensityScoreDistServer.Rd @@ -7,7 +7,6 @@ cohortMethodPropensityScoreDistServer( id, selectedRow, - inputParams, connectionHandler, resultDatabaseSettings, metaAnalysisDbIds = F @@ -18,8 +17,6 @@ cohortMethodPropensityScoreDistServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} diff --git a/man/cohortMethodResultSummaryServer.Rd b/man/cohortMethodResultSummaryServer.Rd new file mode 100644 index 00000000..b32b7b21 --- /dev/null +++ b/man/cohortMethodResultSummaryServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-resultSummary.R +\name{cohortMethodResultSummaryServer} +\alias{cohortMethodResultSummaryServer} +\title{The module server for rendering the PLE diagnostics summary} +\usage{ +cohortMethodResultSummaryServer( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{the connection to the PLE results database} + +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} + +\item{inputSelected}{The target id, comparator id, outcome id and analysis id selected by the user} +} +\value{ +the PLE diagnostics summary results +} +\description{ +The module server for rendering the PLE diagnostics summary +} diff --git a/man/cohortMethodResultSummaryViewer.Rd b/man/cohortMethodResultSummaryViewer.Rd new file mode 100644 index 00000000..d1545136 --- /dev/null +++ b/man/cohortMethodResultSummaryViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-resultSummary.R +\name{cohortMethodResultSummaryViewer} +\alias{cohortMethodResultSummaryViewer} +\title{The module viewer for rendering the cohort method results} +\usage{ +cohortMethodResultSummaryViewer(id) +} +\arguments{ +\item{id}{the unique reference id for the module} +} +\value{ +The user interface to the cohort method diagnostics viewer +} +\description{ +The module viewer for rendering the cohort method results +} diff --git a/man/cohortMethodResultsTableServer.Rd b/man/cohortMethodResultsTableServer.Rd deleted file mode 100644 index 4b86209e..00000000 --- a/man/cohortMethodResultsTableServer.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-resultsTable.R -\name{cohortMethodResultsTableServer} -\alias{cohortMethodResultsTableServer} -\title{The module server for rendering the PLE results per current selections} -\usage{ -cohortMethodResultsTableServer( - id, - connectionHandler, - inputParams, - resultDatabaseSettings -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{inputParams}{the selected study parameters of interest} - -\item{resultDatabaseSettings}{a list containing the result schema and prefixes} -} -\value{ -the PLE main results table server server -} -\description{ -The module server for rendering the PLE results per current selections -} diff --git a/man/cohortMethodResultsTableViewer.Rd b/man/cohortMethodResultsTableViewer.Rd deleted file mode 100644 index b39e34c9..00000000 --- a/man/cohortMethodResultsTableViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-resultsTable.R -\name{cohortMethodResultsTableViewer} -\alias{cohortMethodResultsTableViewer} -\title{The module viewer for rendering the PLE main results} -\usage{ -cohortMethodResultsTableViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the PLE main results -} -\description{ -The module viewer for rendering the PLE main results -} diff --git a/man/cohortMethodSubgroupsServer.Rd b/man/cohortMethodSubgroupsServer.Rd deleted file mode 100644 index 7dfd6e81..00000000 --- a/man/cohortMethodSubgroupsServer.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-subgroups.R -\name{cohortMethodSubgroupsServer} -\alias{cohortMethodSubgroupsServer} -\title{The module server for rendering the subgroup results} -\usage{ -cohortMethodSubgroupsServer( - id, - selectedRow, - inputParams, - exposureOfInterest, - outcomeOfInterest, - connectionHandler -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{exposureOfInterest}{exposureOfInterest} - -\item{outcomeOfInterest}{outcomeOfInterest} - -\item{connectionHandler}{connection} -} -\value{ -the PLE subgroup results server -} -\description{ -The module server for rendering the subgroup results -} diff --git a/man/cohortMethodSubgroupsViewer.Rd b/man/cohortMethodSubgroupsViewer.Rd deleted file mode 100644 index 1eeb52f5..00000000 --- a/man/cohortMethodSubgroupsViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohort-method-subgroups.R -\name{cohortMethodSubgroupsViewer} -\alias{cohortMethodSubgroupsViewer} -\title{The module viewer for rendering the PLE subgroup results} -\usage{ -cohortMethodSubgroupsViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the cohort method subgroup results module -} -\description{ -The module viewer for rendering the PLE subgroup results -} diff --git a/man/cohortMethodSystematicErrorServer.Rd b/man/cohortMethodSystematicErrorServer.Rd index d470cf17..3f44490e 100644 --- a/man/cohortMethodSystematicErrorServer.Rd +++ b/man/cohortMethodSystematicErrorServer.Rd @@ -7,10 +7,8 @@ cohortMethodSystematicErrorServer( id, selectedRow, - inputParams, connectionHandler, - resultDatabaseSettings, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) } \arguments{ @@ -18,13 +16,9 @@ cohortMethodSystematicErrorServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection handler to the result databases} \item{resultDatabaseSettings}{a list containing the result schema and prefixes} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} } \value{ the PLE systematic error content server diff --git a/tests/testthat/test-cohort-method-CovariateBalance.R b/tests/testthat/test-cohort-method-CovariateBalance.R index dbe1a6db..53d12c52 100644 --- a/tests/testthat/test-cohort-method-CovariateBalance.R +++ b/tests/testthat/test-cohort-method-CovariateBalance.R @@ -4,14 +4,8 @@ shiny::testServer( app = cohortMethodCovariateBalanceServer, args = list( selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - metaAnalysisDbIds = '1' + resultDatabaseSettings = resultDatabaseSettingsCm ), expr = { @@ -19,25 +13,120 @@ shiny::testServer( testthat::expect_true(is.null(balance())) # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) + + testthat::expect_true(!is.null(output$balanceSummaryPlot)) testthat::expect_true(!is.null(balance())) testthat::expect_true(nrow(balance())>0) - testthat::expect_true(!is.null(balancePlot())) - testthat::expect_true(!is.null(output$balancePlotCaption)) - #session$setInputs(plotHoverBalanceScatter = list( - # x = balance()$absBeforeMatchingStdDiff[1], - # y = balance()$absAfterMatchingStdDiff[1], - # domain = list(left = 0.9, right = 1, top = 3, bottom = 0), - # range = list(left = 3, right = 5, top = 3, bottom = 0) - # ) - #) - #testthat::expect_true(!is.null(output$hoverInfoBalanceScatter)) - ##testthat::expect_true(!is.null(balanceSummaryPlot())) - doesnt work testthat::expect_true(!is.null(output$balanceSummaryPlotCaption)) # check textsearch textSearchCohortMethod('heart') + + balance <- getCohortMethodCovariateBalanceShared( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + databaseId = '1', + analysisId = 2) + + testthat::expect_true(!is.null(balance)) + testthat::expect_true(nrow(balance)>0) + + plot <- plotCohortMethodCovariateBalanceScatterPlotNew( + balance = balance, + beforeLabel = "Before propensity score adjustment", + afterLabel = "After propensity score adjustment" + ) + + testthat::expect_is(object = plot, class = 'plotly') + + }) + + + +test_that("plotCohortMethodCovariateBalanceSummary", { + + # not the output of getEstimationCovariateBalance - where does it come from?? + balance <- data.frame( + databaseId = rep(1,2), + #covariateId = 1, + #covariateName = '1', + #analysisId = 1, + #beforeMatchingMeanTreated = 1, + #beforeMatchingMeanComparator = 1, + #beforeMatchingStdDiff = 0, + #afterMatchingMeanTreated = 1, + #afterMatchingMeanComparator = 1, + #afterMatchingStdDiff = 0, + absBeforeMatchingStdDiff = c(0.1,0.4), + absAfterMatchingStdDiff = c(0.1,0.4), + x = rep(1,2), + ymin = rep(1,2), + lower = rep(1,2), + median = rep(1,2), + upper = rep(1,2), + ymax = rep(1,2), + covariateCount = rep(1,2), + type = c("Before matching","After matching") + ) + + # added test for this in covariatebal + #resP <- plotEstimationCovariateBalanceScatterPlotNew( + # balance = balance, + # beforeLabel = "Before matching", + # afterLabel = "After matching", + # textsearch = shiny::reactiveVal(NULL) + #) + #testthat::expect_true(inherits(resP, 'plotly')) + + balanceSummary <- data.frame( + databaseId = rep(1,2), + #covariateId = 1, + #covariateName = '1', + #analysisId = 1, + #beforeMatchingMeanTreated = 1, + #beforeMatchingMeanComparator = 1, + #beforeMatchingStdDiff = 0, + #afterMatchingMeanTreated = 1, + #afterMatchingMeanComparator = 1, + #afterMatchingStdDiff = 0, + x = rep(1,2), + ymin = rep(1,2), + lower = rep(1,2), + median = rep(1,2), + upper = rep(1,2), + ymax = rep(1,2), + covariateCount = rep(1,2), + type = c("Before matching","After matching") + ) + + resP <- plotCohortMethodCovariateBalanceSummary( + balanceSummary = balanceSummary, + threshold = 0, + beforeLabel = "Before matching", + afterLabel = "After matching" + ) + + testthat::expect_true(inherits(resP, 'gtable')) + +}) \ No newline at end of file diff --git a/tests/testthat/test-cohort-method-DiagnosticsSummary.R b/tests/testthat/test-cohort-method-DiagnosticsSummary.R index b0ea4297..c9993dcb 100644 --- a/tests/testthat/test-cohort-method-DiagnosticsSummary.R +++ b/tests/testthat/test-cohort-method-DiagnosticsSummary.R @@ -13,25 +13,6 @@ shiny::testServer( }) -test_that("styleColumns", { - - oid <- c(1,34) - names(oid) <- c('a','b') - aid <- c(3) - names(aid) <- c('none') - -colss <- styleColumns( - customColDefs = list(a=1), - outcomeIds = oid, - analysisIds = aid -) - -testthat::expect_is(colss, 'list') -names(colss) <- c('a', 'a_none', 'b_none') -testthat::expect_is(colss$b_none$style, 'function') -testthat::expect_equal(colss$b_none$style('Pass')$background,"#AFE1AF") -}) - test_that("diagnosticSummaryFormat", { datar <- function(){ @@ -48,59 +29,35 @@ testthat::expect_true(ncol(val) == 4) }) -test_that("getCmDiagCohorts", { - -cohortIds <- getCmDiagCohorts( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - type = 'target' - ) +test_that("getCmDiagnosticData", { +colDefs <- getColDefsCmDiag( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm +) -testthat::expect_true(length(cohortIds) > 0) -}) +testthat::expect_is(colDefs, 'list') +testthat::expect_is(colDefs[[1]], 'colDef') -test_that("getCmDiagAnalyses", { - - analysisIds <- getCmDiagAnalyses( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm - ) - - testthat::expect_true(length(analysisIds) > 0) }) -test_that("getCmDiagAnalyses", { - - analysisIds <- getCmDiagAnalyses( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm - ) - - cohortIds <- getCmDiagCohorts( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - type = 'target' - ) +test_that("getCmDiagnosticData", { - outcomeIds <- getCmDiagCohorts( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - type = 'outcome' - ) - - comparatorIds <- getCmDiagCohorts( - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - type = 'comparator' - ) + inputSelected <- function(){ + return( + list( + targetIds = 1, + comparatorIds = 2, + outcomeIds = 3, + analysesIds = c(1,2) + ) + ) + } + diag <- getCmDiagnosticsData( connectionHandler = connectionHandlerCm, resultDatabaseSettings = resultDatabaseSettingsCm, - targetIds = cohortIds, - outcomeIds = outcomeIds, - comparatorIds = comparatorIds, - analysisIds = analysisIds + inputSelected ) testthat::expect_true(nrow(diag) > 0) diff --git a/tests/testthat/test-cohort-method-ForestPlot.R b/tests/testthat/test-cohort-method-ForestPlot.R deleted file mode 100644 index 4d06b076..00000000 --- a/tests/testthat/test-cohort-method-ForestPlot.R +++ /dev/null @@ -1,21 +0,0 @@ -context("cohort-method-ForestPlot") - -shiny::testServer( - app = cohortMethodForestPlotServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - metaAnalysisDbIds = NULL - ), - expr = { - - # doesnt seem to be currently used? - testthat::expect_true(is.null(forestPlot())) - - }) diff --git a/tests/testthat/test-cohort-method-KaplanMeier.R b/tests/testthat/test-cohort-method-KaplanMeier.R index a05a3d0d..a3bff823 100644 --- a/tests/testthat/test-cohort-method-KaplanMeier.R +++ b/tests/testthat/test-cohort-method-KaplanMeier.R @@ -4,14 +4,8 @@ shiny::testServer( app = cohortMethodKaplanMeierServer, args = list( selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - metaAnalysisDbIds = '1' + resultDatabaseSettings = resultDatabaseSettingsCm ), expr = { @@ -19,7 +13,21 @@ shiny::testServer( testthat::expect_true(is.null(kaplanMeierPlot())) # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 1, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) testthat::expect_true(!is.null(kaplanMeierPlot())) testthat::expect_true(!is.null(output$kaplanMeierPlotPlotCaption)) diff --git a/tests/testthat/test-cohort-method-PopulationCharacteristics.R b/tests/testthat/test-cohort-method-PopulationCharacteristics.R index cd204937..80dd2f50 100644 --- a/tests/testthat/test-cohort-method-PopulationCharacteristics.R +++ b/tests/testthat/test-cohort-method-PopulationCharacteristics.R @@ -4,21 +4,27 @@ shiny::testServer( app = cohortMethodPopulationCharacteristicsServer, args = list( selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), connectionHandler = connectionHandlerCm, resultDatabaseSettings = resultDatabaseSettingsCm - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - #metaAnalysisDbIds = '1' ), expr = { # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 1, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) testthat::expect_true(!is.null(output$table1Table)) testthat::expect_true(!is.null(output$table1Caption)) diff --git a/tests/testthat/test-cohort-method-Power.R b/tests/testthat/test-cohort-method-Power.R index 6d85bb5f..770149a9 100644 --- a/tests/testthat/test-cohort-method-Power.R +++ b/tests/testthat/test-cohort-method-Power.R @@ -3,30 +3,52 @@ context("cohort-method-Power") shiny::testServer( app = cohortMethodPowerServer, args = list( - selectedRow = shiny::reactiveVal( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), + selectedRow = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - metaAnalysisDbIds = NULL + resultDatabaseSettings = resultDatabaseSettingsCm ), expr = { #testthat::expect_true(is.null(output$powerTable)) - # make sure this runs if we pick the first row - #selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F)) + followUp <- getCmFollowUpDist( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + outcomeId = 3, + databaseId = '1', + analysisId = 2 + ) + testthat::expect_true(nrow(followUp)>0) + + tablet <- prepareCohortMethodFollowUpDistTable(followUp) + testthat::expect_true(nrow(tablet)>0) + # make sure this runs if we pick the first row + selectedRow( + data.frame( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = F, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) testthat::expect_true(!is.null(output$powerTable)) testthat::expect_true(!is.null(output$powerTableCaption)) testthat::expect_true(!is.null(output$timeAtRiskTableCaption)) diff --git a/tests/testthat/test-cohort-method-PropensityScoreDist.R b/tests/testthat/test-cohort-method-PropensityScoreDist.R index 93ba27da..975f1c78 100644 --- a/tests/testthat/test-cohort-method-PropensityScoreDist.R +++ b/tests/testthat/test-cohort-method-PropensityScoreDist.R @@ -3,33 +3,50 @@ context("cohort-method-PropensityScoreDist") shiny::testServer( app = cohortMethodPropensityScoreDistServer, args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), + selectedRow = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - metaAnalysisDbIds = NULL + resultDatabaseSettings = resultDatabaseSettingsCm ), expr = { testthat::expect_true(is.null(psDistPlot())) + ps <- getCohortMethodPs( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + analysisId = 2, + databaseId = '1' + ) + + testthat::expect_true('preferenceScore' %in% colnames(ps)) + testthat::expect_true('targetDensity' %in% colnames(ps)) + testthat::expect_true('comparatorDensity' %in% colnames(ps)) + # make sure this runs if we pick the first row selectedRow( - - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = 0, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) ) testthat::expect_true(!is.null(psDistPlot())) diff --git a/tests/testthat/test-cohort-method-ResultsTable.R b/tests/testthat/test-cohort-method-ResultsTable.R deleted file mode 100644 index bdf3a781..00000000 --- a/tests/testthat/test-cohort-method-ResultsTable.R +++ /dev/null @@ -1,39 +0,0 @@ -context("cohort-method-ResultsTable") - -shiny::testServer( - app = cohortMethodResultsTableServer, - args = list( - #selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - #), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), - connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm - ), - expr = { - - # check result table loads - testthat::expect_true(!is.null(resultSubset())) - - # select first row - testthat::expect_true(is.null(selectedRow())) - #reactable::updateReactable( - # outputId = "mainTable", - # selected = 1, - # session = session - # ) - session$setInputs(mainTable__reactable__selected = 1) - #session$setInputs(mainTable_rows_selected = 1) - testthat::expect_true(!is.null(selectedRow())) # could check columns - - - }) diff --git a/tests/testthat/test-cohort-method-Subgroups.R b/tests/testthat/test-cohort-method-Subgroups.R deleted file mode 100644 index 74a44997..00000000 --- a/tests/testthat/test-cohort-method-Subgroups.R +++ /dev/null @@ -1,53 +0,0 @@ -context("cohort-method-Subgroups") - - -# tests cannot be done due to getEstimationSubgroupResults() missing? -if(F){ -shiny::testServer( - app = cohortMethodSubgroupsServer, - args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), - connectionHandler = connectionHandlerCm, - exposureOfInterest = list(exposureId = c(1,2), exposureName = c(1,2)), - outcomeOfInterest = list(outcomeId = 3, outcomeName = 3) - #resultsSchema = 'main', - #tablePrefix = 'cm_', - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable - #metaAnalysisDbIds = NULL - ), - expr = { - - # check result table loads - testthat::expect_true(is.null(interactionEffects())) - - # select first row - selectedRow( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ) - # setting selectedRow() activates the following - testthat::expect_true(!is.null(interactionEffects())) - - testthat::expect_true(!is.null(output$subgroupTableCaption)) - testthat::expect_true(!is.null(output$subgroupTable)) - - # add code to test blind works - - }) - -} diff --git a/tests/testthat/test-cohort-method-attrition.R b/tests/testthat/test-cohort-method-attrition.R index f47dfb04..f1439766 100644 --- a/tests/testthat/test-cohort-method-attrition.R +++ b/tests/testthat/test-cohort-method-attrition.R @@ -3,12 +3,9 @@ context("cohort-method-attrition") shiny::testServer( app = cohortMethodAttritionServer, args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), + selectedRow = shiny::reactiveVal( + NULL + ), connectionHandler = connectionHandlerCm, resultDatabaseSettings = resultDatabaseSettingsCm ), @@ -18,7 +15,20 @@ shiny::testServer( testthat::expect_true(is.null(attritionPlot())) # make sure this runs if we pick the first row - selectedRow(list(databaseId = 'Eunomia', analysisId = 1)) + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome' + ) + ) testthat::expect_true(!is.null(attritionPlot())) }) diff --git a/tests/testthat/test-cohort-method-full-result.R b/tests/testthat/test-cohort-method-full-result.R new file mode 100644 index 00000000..5ad28c8d --- /dev/null +++ b/tests/testthat/test-cohort-method-full-result.R @@ -0,0 +1,34 @@ +context("cohort-method-full-result") + +shiny::testServer( + app = cohortMethodFullResultServer, + args = list( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + selectedRow = shiny::reactiveVal(NULL) + ), + expr = { + + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome' + ) + ) + + }) + + +test_that("Test full ui", { + # Test ui + ui <- cohortMethodFullResultViewer('test') + checkmate::expect_list(ui) +}) \ No newline at end of file diff --git a/tests/testthat/test-cohort-method-main.R b/tests/testthat/test-cohort-method-main.R index a9833a18..6c5b4bc9 100644 --- a/tests/testthat/test-cohort-method-main.R +++ b/tests/testthat/test-cohort-method-main.R @@ -10,17 +10,7 @@ shiny::testServer( testthat::expect_true(inherits(connectionHandler,"ConnectionHandler")) - - testthat::expect_true(!is.null(output$targetWidget)) - testthat::expect_true(!is.null(output$comparatorWidget)) - testthat::expect_true(!is.null(output$outcomeWidget)) - testthat::expect_true(!is.null(output$databaseWidget)) - testthat::expect_true(!is.null(output$analysisWidget)) - - # check setting target updates inputParams - session$setInputs(target = '1') - testthat::expect_true(inputParams()$target == '1') - + testthat::expect_true(!is.null(targetIds)) }) diff --git a/tests/testthat/test-cohort-method-propensityModel.R b/tests/testthat/test-cohort-method-propensityModel.R index 568eff83..ca5e6b62 100644 --- a/tests/testthat/test-cohort-method-propensityModel.R +++ b/tests/testthat/test-cohort-method-propensityModel.R @@ -3,30 +3,38 @@ context("cohort-method-propensityModel") shiny::testServer( app = cohortMethodPropensityModelServer, args = list( - selectedRow = shiny::reactiveVal( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), + selectedRow = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerCm, resultDatabaseSettings = resultDatabaseSettingsCm - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - #metaAnalysisDbIds = NULL ), expr = { #testthat::expect_true(is.null(output$powerTable)) # make sure this runs if we pick the first row - #selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F)) - + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = F, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) testthat::expect_true(!is.null(output$propensityModelTable)) diff --git a/tests/testthat/test-cohort-method-systematicError.R b/tests/testthat/test-cohort-method-systematicError.R index 95bd76ba..cfad0323 100644 --- a/tests/testthat/test-cohort-method-systematicError.R +++ b/tests/testthat/test-cohort-method-systematicError.R @@ -5,22 +5,9 @@ context("cohort-method-systematicError") shiny::testServer( app = cohortMethodSystematicErrorServer, args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), + selectedRow = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerCm, - resultDatabaseSettings = resultDatabaseSettingsCm, - metaAnalysisDbIds = 1 + resultDatabaseSettings = resultDatabaseSettingsCm ), expr = { @@ -29,15 +16,56 @@ shiny::testServer( # select first row selectedRow( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = 0, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) ) # setting selectedRow() activates the following ##testthat::expect_true(!is.null(systematicErrorPlot())) - ##testthat::expect_true(!is.null(output$systematicErrorPlot)) + testthat::expect_true(!is.null(output$systematicErrorPlot)) ##testthat::expect_true(!is.null(systematicErrorSummaryPlot())) ##testthat::expect_true(!is.null(output$systematicErrorSummaryPlot)) }) + + + +test_that("plotCohortMethodScatter", { + + + controlResults <- data.frame( + databaseId = 1:10, + seLogRr = runif(10), + logRr = runif(10), + ci95Lb = runif(10), + ci95Ub = runif(10), + effectSize = runif(10), + calibratedLogRr = runif(10), + calibratedSeLogRr = runif(10), + calibratedCi95Lb = runif(10), + calibratedCi95Ub = runif(10), + trueRr = rep(1,10) + + ) + resP <- plotCohortMethodScatter(controlResults) + testthat::expect_true(inherits(resP, 'ggplot')) + +}) diff --git a/tests/testthat/test-evidence-synth-main.R b/tests/testthat/test-evidence-synth-main.R index 12ececae..3fd7d382 100644 --- a/tests/testthat/test-evidence-synth-main.R +++ b/tests/testthat/test-evidence-synth-main.R @@ -9,13 +9,21 @@ shiny::testServer(evidenceSynthesisServer, args = list( expect_true(length(targetIds) > 0) expect_true(length(outcomeIds) > 0) - #session$setInputs( - # `input-selection-targetId` = 1, - # `input-selection-outcomeId` = 3, - # `input-selection-generate` = 1 - #) + inputSelected( + list( + targetId = targetIds[1], + targetIds = targetIds[1], + target = 'test target', + comparatorId = 2, + comparator = 'test comparator', + outcome = 'test outcome', + outcomeId = 3, + outcomeIds = 3 + ) + ) + + testthat::expect_is(output$esCohortMethodPlot, 'list') - inputSelected(list(targetId = targetIds[1], outcomeId = 3)) testthat::expect_true( nrow(unique(rbind(data(),data2()))) >0 ) testthat::expect_equal(as.double(inputSelected()$outcomeId), 3) diff --git a/tests/testthat/test-helpers-cohort-methodPlotsAndTables.R b/tests/testthat/test-helpers-cohort-methodPlotsAndTables.R deleted file mode 100644 index c81e96cd..00000000 --- a/tests/testthat/test-helpers-cohort-methodPlotsAndTables.R +++ /dev/null @@ -1,190 +0,0 @@ -context('tests-helpers-cohort-methodPlotsAndTables') - -test_that("Subgroup stuff", { - -subgroupRes <- getCohortMethodSubgroupResults( - connectionHandler = connectionHandlerCm, - targetIds = 1, - comparatorIds = 2, - outcomeIds = 3, - databaseIds = 1, - analysisIds = 1, - subgroupIds = 372328212, - cmInteractionResult = data.frame( - targetId = 1, - comparatorId = 2, - outcomeId = 3, - databaseId = 1, - analysisId = 1, - interactionCovariateId = 372328212, - targetSubjects = 10, - comparatorSubjects =10, - rrr = 1, - ci95Lb = 1, - ci95Ub = 1, - p = 1, - calibratedP = 1 - ), - covariate = list( - covariateId = 372328212, - covariateName = 'test', - databaseId = 1 - ) - ) - -testthat::expect_true(nrow(subgroupRes) > 0) - -res <- prepareCohortMethodSubgroupTable(subgroupResults = subgroupRes, output = "latex") -testthat::expect_true(nrow(res) > 0) - -}) - - -test_that("CovariateBalance stuff", { - - # not the output of getEstimationCovariateBalance - where does it come from?? - balance <- data.frame( - databaseId = rep(1,2), - #covariateId = 1, - #covariateName = '1', - #analysisId = 1, - #beforeMatchingMeanTreated = 1, - #beforeMatchingMeanComparator = 1, - #beforeMatchingStdDiff = 0, - #afterMatchingMeanTreated = 1, - #afterMatchingMeanComparator = 1, - #afterMatchingStdDiff = 0, - absBeforeMatchingStdDiff = c(0.1,0.4), - absAfterMatchingStdDiff = c(0.1,0.4), - x = rep(1,2), - ymin = rep(1,2), - lower = rep(1,2), - median = rep(1,2), - upper = rep(1,2), - ymax = rep(1,2), - covariateCount = rep(1,2), - type = c("Before matching","After matching") - ) - - # added test for this in covariatebal - #resP <- plotEstimationCovariateBalanceScatterPlotNew( - # balance = balance, - # beforeLabel = "Before matching", - # afterLabel = "After matching", - # textsearch = shiny::reactiveVal(NULL) - #) - #testthat::expect_true(inherits(resP, 'plotly')) - - balanceSummary <- data.frame( - databaseId = rep(1,2), - #covariateId = 1, - #covariateName = '1', - #analysisId = 1, - #beforeMatchingMeanTreated = 1, - #beforeMatchingMeanComparator = 1, - #beforeMatchingStdDiff = 0, - #afterMatchingMeanTreated = 1, - #afterMatchingMeanComparator = 1, - #afterMatchingStdDiff = 0, - x = rep(1,2), - ymin = rep(1,2), - lower = rep(1,2), - median = rep(1,2), - upper = rep(1,2), - ymax = rep(1,2), - covariateCount = rep(1,2), - type = c("Before matching","After matching") - ) - - resP <- plotCohortMethodCovariateBalanceSummary( - balanceSummary = balanceSummary, - threshold = 0, - beforeLabel = "Before matching", - afterLabel = "After matching" - ) - - testthat::expect_true(inherits(resP, 'gtable')) - -}) - -test_that("nonZeroCohortMethodHazardRatio", { - - testthat::expect_equal( - nonZeroCohortMethodHazardRatio(hrLower = 0.5, hrUpper = 0.5, terms = 'test'), - 'test' - ) - testthat::expect_equal( - nonZeroCohortMethodHazardRatio(hrLower = 1.1, hrUpper = 1.1, terms = c('test','sec')), - 'sec' - ) - testthat::expect_equal( - nonZeroCohortMethodHazardRatio(hrLower = 0.9, hrUpper = 1.1, terms = c('test','sec','3')), - '3' - ) - -}) - -test_that("goodCohortMethodPropensityScore", { - testthat::expect_equal(goodCohortMethodPropensityScore(0.5), F) - testthat::expect_equal(goodCohortMethodPropensityScore(1), F) - testthat::expect_equal(goodCohortMethodPropensityScore(1.01), T) -}) - -test_that("goodCohortMethodSystematicBias", { - testthat::expect_equal(goodCohortMethodSystematicBias(0.5), F) - testthat::expect_equal(goodCohortMethodSystematicBias(1), F) - testthat::expect_equal(goodCohortMethodSystematicBias(1.01), T) -}) - - -test_that("plotCohortMethodForest", { - - results <- data.frame( - databaseId = 1:10, - seLogRr = runif(10), - logRr = runif(10), - ci95Lb = runif(10), - ci95Ub = runif(10), - calibratedLogRr = runif(10), - calibratedCi95Lb = runif(10), - calibratedCi95Ub = runif(10), - i2 = runif(10) - ) -resP <- plotCohortMethodForest(results, limits = c(0.1, 10), metaAnalysisDbIds = 2) -testthat::expect_true(inherits(resP, 'gtable')) - -}) - -test_that("plotCohortMethodScatter", { - - - controlResults <- data.frame( - databaseId = 1:10, - seLogRr = runif(10), - logRr = runif(10), - ci95Lb = runif(10), - ci95Ub = runif(10), - effectSize = runif(10), - calibratedLogRr = runif(10), - calibratedSeLogRr = runif(10), - calibratedCi95Lb = runif(10), - calibratedCi95Ub = runif(10), - trueRr = rep(1,10) - - ) - resP <- plotCohortMethodScatter(controlResults) - testthat::expect_true(inherits(resP, 'ggplot')) - -}) - -## Functions remaining to add tests: -# getCohortMethodTcoChoice -# getCohortMethodTargetChoices -# getCohortMethodComparatorChoices -# getCohortMethodOutcomeChoices -# getCohortMethodDatabaseChoices -# getCmAnalysisOptions -# getAllCohortMethodResults -# getCohortMethodControlResults -# getCohortMethodStudyPeriod -# getCohortMethodNegativeControlEstimates