From 0d8f8454c79cbc889d750f2fc7ae58e9b57aac0e Mon Sep 17 00:00:00 2001 From: Nathan Hall <106178605+nhall6@users.noreply.github.com> Date: Fri, 20 Sep 2024 12:53:11 -0400 Subject: [PATCH] Issue114 (#339) * Fixing Power tables re: #114 Standardizing power table outputs to adhere to OSM standard theme (reactable via resultTableViewer and resultTableServer). Also split the tables into 2 sub-tabs for easier readability * Updating propensity score table Adding conditional formatting of colors to values to aid in interpretation, and also adding an absolute value of beta column. * Updates to propensity score plot Overlaying equipoise statistic onto the plot, and truncating cohort names in legend * Updating covariate balance plot Adding maxSDM to covariate balance plot * Updating captions and systematic error Adding to caption descriptions in figures and overlaying EASE statistic on systematic error plot * Updating systematic error Adding more descriptive filenames for plot downloads * Develop (#340) * Fixing #301 (#326) Adding alphabetical sort to DB input options * Fixing #296 (#327) Standardizing pickerInput type for database selection where multiple options are possible to improve UX. Also fixed some colDefs in Exposed Cases * Fixing #302 and Filtered Data Downloads (#332) * Fixing #302 and Filtered Data Downloads All filtered data downloads across all modules should work now, with a button styled the same as the full download. It needs to be a CSV handler though due to the reactable statte * Updating the fix Also fixed download buttons in Cohorts module, addressing #298 * Update R_CMD_check_Hades.yaml * Update R_CMD_check_Hades.yaml * Update R_CMD_check_Hades.yaml * fixing R checks fixing R checks * Update cohort-diagnostics-databaseInformation.R (#333) Fixing the issue reported in https://github.com/OHDSI/OhdsiShinyModules/issues/162 * fixing issue issue_330 (#334) fixing time plot x-axis * fixing issue 167 (#335) added code to get long database names on multiple lines * Update cohort-diagnostics-timeDistributions.R (#336) adding fix for issue 168 * Update patient-level-prediction-modelSummary.R (#337) --------- Co-authored-by: Nathan Hall <106178605+nhall6@users.noreply.github.com> * fixing testing errors --------- Co-authored-by: jreps --- DESCRIPTION | 2 +- R/estimation-cohort-method-covariateBalance.R | 87 ++++++- R/estimation-cohort-method-power.R | 238 +++++++++++++++--- R/estimation-cohort-method-propensityModel.R | 40 ++- ...ohort-method-propensityScoreDistribution.R | 72 +++++- R/estimation-cohort-method-systematicError.R | 92 ++++++- tests/testthat/Rplots.pdf | Bin 0 -> 10146 bytes .../test-estimation-cohort-method-power.R | 4 +- 8 files changed, 480 insertions(+), 55 deletions(-) create mode 100644 tests/testthat/Rplots.pdf diff --git a/DESCRIPTION b/DESCRIPTION index 16e4363..74e2694 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,4 +62,4 @@ Suggests: Remotes: ohdsi/ReportGenerator, ohdsi/ResultModelManager -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 diff --git a/R/estimation-cohort-method-covariateBalance.R b/R/estimation-cohort-method-covariateBalance.R index 7041056..39656b2 100644 --- a/R/estimation-cohort-method-covariateBalance.R +++ b/R/estimation-cohort-method-covariateBalance.R @@ -112,6 +112,7 @@ cohortMethodCovariateBalanceServer <- function( analysisId = row$analysisId)}, error = function(e){return(data.frame())} ) + return(balance) }) @@ -127,6 +128,22 @@ cohortMethodCovariateBalanceServer <- function( ) balancePlot <- shiny::reactive({ + + row <- selectedRow() + if(is.null(row$targetId)){ + return(NULL) + } + + maxSdmStatistic <- estimationGetMaxSdm( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, + analysisId = row$analysisId, + databaseId = row$databaseId + ) + if (is.null(balance()) || nrow(balance()) == 0) { return(NULL) } else { @@ -134,7 +151,8 @@ cohortMethodCovariateBalanceServer <- function( balance = balance(), beforeLabel = "Before propensity score adjustment", afterLabel = "After propensity score adjustment", - textsearch = textSearchCohortMethod + textsearch = textSearchCohortMethod, + maxSdmStatistic ) return(plot) } @@ -151,7 +169,7 @@ cohortMethodCovariateBalanceServer <- function( row <- selectedRow() text <- "Figure 3. Covariate balance before and after propensity score adjustment. Each dot represents the standardizes difference of means for a single covariate before and after propensity score adjustment on the propensity - score. Move the mouse arrow over a dot for more details." + score. The maximum absolute standardized difference of the mean (Max SDM) is given at the top of the figure. Move the mouse arrow over a dot for more details." return(shiny::HTML(sprintf(text))) } }) @@ -421,13 +439,24 @@ getCohortMethodCovariateBalanceSummary <- function( } +cmDiagnostics <- shiny::reactive({ + estimationGetCmDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId + ) +}) + plotCohortMethodCovariateBalanceScatterPlotNew <- function( balance, beforeLabel = "Before propensity score adjustment", afterLabel = "After propensity score adjustment", - textsearch = shiny::reactiveVal(NULL) + textsearch = shiny::reactiveVal(NULL), + maxSdmStatistic = NULL ){ if(is.null(textsearch())){ @@ -469,6 +498,7 @@ plotCohortMethodCovariateBalanceScatterPlotNew <- function( ) %>% plotly::layout( #shapes = list(xyline(limits)), + title = ~paste0("Max SDM Statistic = ", maxSdmStatistic), shapes = list(list( type = "line", x0 = 0, @@ -589,6 +619,57 @@ getCmOptions <- function(connectionHandler, } +estimationGetMaxSdm <- function( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId, + comparatorId = comparatorId, + outcomeId = outcomeId, + analysisId = analysisId, + databaseId = databaseId +){ + + sql <- " + SELECT DISTINCT + dmd.cdm_source_abbreviation database_name, + cmds.analysis_id, + cmds.target_id, + cmds.comparator_id, + cmds.outcome_id, + cmds.max_sdm, + cmds.ease + FROM + @schema.@cm_table_prefixdiagnostics_summary cmds + INNER JOIN @schema.@database_table dmd ON dmd.database_id = cmds.database_id + + where cmds.target_id = @target_id + and cmds.comparator_id = @comparator_id + and cmds.outcome_id = @outcome_id + and cmds.analysis_id = @analysis_id + and cmds.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 + ) + + maxSdm <- round(result$maxSdm, 4) + + return( + maxSdm + ) + +} + diff --git a/R/estimation-cohort-method-power.R b/R/estimation-cohort-method-power.R index 2acec47..d54cb99 100644 --- a/R/estimation-cohort-method-power.R +++ b/R/estimation-cohort-method-power.R @@ -30,10 +30,25 @@ cohortMethodPowerViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - shiny::uiOutput(outputId = ns("powerTableCaption")), - shiny::tableOutput(outputId = ns("powerTable")), - shiny::uiOutput(outputId = ns("timeAtRiskTableCaption")), - shiny::tableOutput(outputId = ns("timeAtRiskTable")) + shiny::tabsetPanel( + type = 'pills', + id = ns('power'), + + shiny::tabPanel( + title = "Power Table", + resultTableViewer(ns("powerTable"), + downloadedFileName = "powerTable-"), + shiny::uiOutput(outputId = ns("powerTableCaption")) + ), + + shiny::tabPanel( + title = "TAR Table", + resultTableViewer(ns("timeAtRiskTable"), + downloadedFileName = "timeAtRiskTable-"), + shiny::uiOutput(outputId = ns("timeAtRiskTableCaption")) + ) + + ) ) } @@ -74,36 +89,102 @@ cohortMethodPowerServer <- function( } }) - output$powerTable <- shiny::renderTable({ + powerTable <- shiny::reactive({ row <- selectedRow() if (is.null(row$target)) { return(NULL) } else { - table <- prepareCohortMethodPowerTable( - row, - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) - if (!row$unblind) { - table$targetOutcomes <- NA - table$comparatorOutcomes <- NA - table$targetIr <- NA - table$comparatorIr <- NA - } - colnames(table) <- c("Target subjects", - "Comparator subjects", - "Target years", - "Comparator years", - "Target events", - "Comparator events", - "Target IR (per 1,000 PY)", - "Comparator IR (per 1,000 PY)", - "MDRR") + table <- prepareCohortMethodPowerTable( + row, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + if (!row$unblind) { + table$targetOutcomes <- NA + table$comparatorOutcomes <- NA + table$targetIr <- NA + table$comparatorIr <- NA + } + colnames(table) <- c("targetSubjects", + "comparatorSubjects", + "targetYears", + "comparatorYears", + "targetEvents", + "comparatorEvents", + "targetIr", # (per 1,000 PY)", + "comparatorIr", # (per 1,000 PY)", + "mdrr") return(table) } }) + estimationPowerTableColDefs <- function(){ + result <- list( + targetSubjects = reactable::colDef( + header = withTooltip("Target Subjects", + "Number of subjects in the target cohort"), + filterable = T + ), + comparatorSubjects = reactable::colDef( + header = withTooltip("Comparator Subjects", + "Number of subjects in the comparator cohort"), + filterable = T + ), + targetYears = reactable::colDef( + header = withTooltip("Target Years", + "Number of years of follow-up time in the target cohort"), + filterable = T + ), + comparatorYears = reactable::colDef( + header = withTooltip("Comparator Years", + "Number of years of follow-up time in the comparator cohort"), + filterable = T + ), + targetEvents = reactable::colDef( + header = withTooltip("Target Events", + "Distinct number of outcome events in the target cohort"), + filterable = T + # cell = function(value) { + # # Add < if cencored + # if (value < 0 ) paste("<", abs(value)) else abs(value) + # } + ), + comparatorEvents = reactable::colDef( + header = withTooltip("Comparator Events", + "Distinct number of outcome events in the comparator cohort"), + filterable = T + # cell = function(value) { + # # Add < if cencored + # if (value < 0 ) paste("<", abs(value)) else abs(value) + # } + ), + targetIr = reactable::colDef( + header = withTooltip("Target IR (per 1,000 PY)", + "Incidence rate per 1,000 person-years in the target cohort"), + filterable = T + ), + comparatorIr = reactable::colDef( + header = withTooltip("Comparator IR (per 1,000 PY)", + "Incidence rate per 1,000 person-years in the comparator cohort"), + filterable = T + ), + mdrr = reactable::colDef( + header = withTooltip("MDRR", + "The minimum detectable relative risk"), + filterable = T + ) + ) + return(result) + } + + resultTableServer( + id = "powerTable", + df = powerTable, + colDefsInput = estimationPowerTableColDefs(), + downloadedFileName = "powerTable-" + ) + output$timeAtRiskTableCaption <- shiny::renderUI({ row <- selectedRow() if (!is.null(row$target)) { @@ -116,25 +197,110 @@ cohortMethodPowerServer <- function( } }) - output$timeAtRiskTable <- shiny::renderTable({ + timeAtRiskTable <- shiny::reactive({ row <- selectedRow() if (is.null(row$target)) { return(NULL) } else { - followUpDist <- getCmFollowUpDist( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = row$targetId, - comparatorId = row$comparatorId, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) + followUpDist <- getCmFollowUpDist( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) table <- prepareCohortMethodFollowUpDistTable(followUpDist) return(table) } }) + + estimationTimeAtRiskTableColDefs <- function(){ + result <- list( + Cohort = reactable::colDef( + header = withTooltip("Cohort", + "Indicates which cohort (target or comparator)"), + filterable = T + ), + Min = reactable::colDef( + header = withTooltip("Min", + "Minimum time (days) at-risk"), + filterable = T + ), + P10 = reactable::colDef( + header = withTooltip("P10", + "10th percentile time (days) at-risk"), + filterable = T + ), + P25 = reactable::colDef( + header = withTooltip("P25", + "25th percentile time (days) at-risk"), + filterable = T + ), + Median = reactable::colDef( + header = withTooltip("Median", + "Median time (days) at-risk"), + filterable = T + ), + P75 = reactable::colDef( + header = withTooltip("P75", + "75th percentile time (days) at-risk"), + filterable = T + ), + P90 = reactable::colDef( + header = withTooltip("P90", + "90th percentile time (days) at-risk"), + filterable = T + ), + Max = reactable::colDef( + header = withTooltip("Max", + "Maximum time (days) at-risk"), + filterable = T + ) + ) + return(result) + } + + resultTableServer( + id = "timeAtRiskTable", + df = timeAtRiskTable, + colDefsInput = estimationTimeAtRiskTableColDefs(), + downloadedFileName = "timeAtRiskTable-" + ) + + output$timeAtRiskTableCaption <- shiny::renderUI({ + row <- selectedRow() + 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, row$target, row$comparator))) + } else { + return(NULL) + } + }) + + # output$timeAtRiskTable <- shiny::renderTable({ + # row <- selectedRow() + # if (is.null(row$target)) { + # return(NULL) + # } else { + # followUpDist <- getCmFollowUpDist( + # connectionHandler = connectionHandler, + # resultDatabaseSettings = resultDatabaseSettings, + # targetId = row$targetId, + # comparatorId = row$comparatorId, + # outcomeId = row$outcomeId, + # databaseId = row$databaseId, + # analysisId = row$analysisId + # ) + # + # table <- prepareCohortMethodFollowUpDistTable(followUpDist) + # return(table) + # } + # }) }) } @@ -280,4 +446,4 @@ getCmFollowUpDist <- function( database_id = databaseId ) ) -} +} \ No newline at end of file diff --git a/R/estimation-cohort-method-propensityModel.R b/R/estimation-cohort-method-propensityModel.R index 9cc201b..070bf1c 100644 --- a/R/estimation-cohort-method-propensityModel.R +++ b/R/estimation-cohort-method-propensityModel.R @@ -66,9 +66,22 @@ cohortMethodPropensityModelServer <- function( comparatorId = selectedRow()$comparatorId, databaseId = selectedRow()$databaseId, analysisId = selectedRow()$analysisId - ) + ) %>% + dplyr::mutate(absBeta = abs(.data$coefficient)) }) + # ColorBrewer-inspired 3-color scale + Yellows <- function(x) grDevices::rgb(grDevices::colorRamp(c("#FFFFDD", "#FFFFB9", "#FFFF79")) + (x), maxColorValue = 255) + + # ColorBrewer-inspired 3-color scale + Blues <- function(x) grDevices::rgb(grDevices::colorRamp(c("aliceblue", "lightblue1", "skyblue2")) + (x), maxColorValue = 255) + + # ColorBrewer-inspired 3-color scale + Greens <- function(x) grDevices::rgb(grDevices::colorRamp(c("#E8FDCF", "yellowgreen")) + (x), maxColorValue = 255) + resultTableServer( id = 'propensityModelTable', df = data, @@ -77,11 +90,34 @@ cohortMethodPropensityModelServer <- function( show = F ), coefficient = reactable::colDef( - name = 'Beta', + name = 'Beta', + cell = function(value) { + if (value >= 0) paste0("+", round(value, 3)) else round(value, 3) + }, + style = function(value) { + color <- if (value > 0) { + "#B0D5FE" + } else if (value < 0) { + "#FEBABA" + } + list(background = color) + }, format = reactable::colFormat( digits = 3 ) ), + absBeta = reactable::colDef( + name = 'Beta (Absolute Value)', + format = reactable::colFormat( + digits = 3 + ), + style = function(value) { + if (!is.numeric(value)) return() + normalized <- (value - min(data()$absBeta)) / (max(data()$absBeta) - min(data()$absBeta)) + color <- Greens(normalized) + list(background = color) + } + ), covariateName = reactable::colDef( name = 'Covariate' ) diff --git a/R/estimation-cohort-method-propensityScoreDistribution.R b/R/estimation-cohort-method-propensityScoreDistribution.R index 7a5eb20..cbac7f1 100644 --- a/R/estimation-cohort-method-propensityScoreDistribution.R +++ b/R/estimation-cohort-method-propensityScoreDistribution.R @@ -32,7 +32,8 @@ cohortMethodPropensityScoreDistViewer <- function(id) { shiny::plotOutput(outputId = ns("psDistPlot")), shiny::div(shiny::strong("Figure 2."),"Preference score distribution. The preference score is a transformation of the propensity score that adjusts for differences in the sizes of the two treatment groups. A higher overlap indicates subjects in the - two groups were more similar in terms of their predicted probability of receiving one treatment over the other."), + two groups were more similar in terms of their predicted probability of receiving one treatment over the other. + The equipoise statistic is also given at the top of the figure."), shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", shiny::downloadButton(outputId = ns("downloadPsDistPlotPng"), label = "Download plot as PNG"), @@ -88,7 +89,17 @@ cohortMethodPropensityScoreDistServer <- function( comparatorName <- row$comparator - plot <- plotCohortMethodPs(ps, targetName, comparatorName) + equipoiseStatistic <- getCohortMethodEquipoise( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, + analysisId = row$analysisId, + databaseId = row$databaseId + ) + + plot <- plotCohortMethodPs(ps, targetName, comparatorName, equipoiseStatistic) return(plot) } }) @@ -113,6 +124,55 @@ cohortMethodPropensityScoreDistServer <- function( ) } +getCohortMethodEquipoise <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + outcomeId, + analysisId, + databaseId = NULL +) { + if(is.null(targetId)){ + return(NULL) + } + sql <- " + SELECT + database_id, target_id, comparator_id, outcome_id, analysis_id, equipoise + FROM + @schema.@cm_table_prefixdiagnostics_summary cmpsd + WHERE + cmpsd.target_id = @target_id + AND cmpsd.comparator_id = @comparator_id + AND cmpsd.analysis_id = @analysis_id + AND cmpsd.outcome_id = @outcome_id + " + if(!is.null(databaseId)) { + sql <- paste(sql, paste("AND cmpsd.database_id = '@database_id'"), collapse = "\n") + } + + + result <- 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 + ) + + + if (!is.null(databaseId)) { + result$databaseId <- NULL + } + + eq <- round(result$equipoise, 4) + + return(eq) +} + getCohortMethodPs <- function( connectionHandler, resultDatabaseSettings, @@ -157,7 +217,7 @@ getCohortMethodPs <- function( } # CohortMethod-propensityScoreDist -plotCohortMethodPs <- function(ps, targetName, comparatorName) { +plotCohortMethodPs <- function(ps, targetName, comparatorName, equipoiseStatistic) { if(is.null(ps$preferenceScore)){ return(NULL) } @@ -180,13 +240,17 @@ plotCohortMethodPs <- function(ps, targetName, comparatorName) { grDevices::rgb(0, 0, 0.8, alpha = 0.5))) + ggplot2::scale_x_continuous("Preference score", limits = c(0, 1)) + ggplot2::scale_y_continuous("Density") + + ggplot2::ggtitle(paste0("Equipoise Statistic = ", equipoiseStatistic)) + ggplot2::theme(legend.title = ggplot2::element_blank(), panel.grid.major = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank(), legend.position = "top", legend.text = theme, axis.text = theme, - axis.title = theme) + axis.title = theme, + plot.title = ggplot2::element_text(vjust = -20) + ) + + ggplot2::guides(fill = ggplot2::guide_legend(nrow = 2)) if (!is.null(ps$databaseId)) { plot <- plot + ggplot2::facet_grid(databaseId~., switch = "both") + ggplot2::theme(legend.position = "right") diff --git a/R/estimation-cohort-method-systematicError.R b/R/estimation-cohort-method-systematicError.R index fa1ce54..b2fd49a 100644 --- a/R/estimation-cohort-method-systematicError.R +++ b/R/estimation-cohort-method-systematicError.R @@ -33,7 +33,8 @@ cohortMethodSystematicErrorViewer <- function(id) { shiny::div(shiny::strong("Figure 4."),"Systematic error. Effect size estimates for the negative controls (true hazard ratio = 1) and positive controls (true hazard ratio > 1), before and after calibration. Estimates below the diagonal dashed lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated - estimator should have the true effect size within the 95 percent confidence interval 95 percent of times."), + estimator should have the true effect size within the 95 percent confidence interval 95 percent of times. + The expected absolute systematic error (EASE) statistic is also shown at the top of the figure."), shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPng"), label = "Download plot as PNG"), @@ -82,6 +83,15 @@ cohortMethodSystematicErrorServer <- function( databaseId = row$databaseId ) + ease <- estimationGetEase( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + analysisId = row$analysisId, + databaseId = row$databaseId + ) + # remove the RR zeros that replace NAs during data upload controlResults$logRr[controlResults$logRr == 0] <- NA controlResults$ci95Lb[controlResults$ci95Lb == 0] <- NA @@ -90,7 +100,7 @@ cohortMethodSystematicErrorServer <- function( controlResults$calibratedCi95Lb[controlResults$calibratedCi95Lb == 0] <- NA controlResults$calibratedCi95Ub[controlResults$calibratedCi95Ub == 0] <- NA - plot <- plotCohortMethodScatter(controlResults) + plot <- plotCohortMethodScatter(controlResults, ease) return(plot) } }) @@ -99,8 +109,25 @@ cohortMethodSystematicErrorServer <- function( return(systematicErrorPlot()) }) + picName <- shiny::reactive({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + picName <- paste0("Target=", stringr::str_trunc(row$target, 35), "_", + "Comparator=",stringr::str_trunc(row$comparator, 35), "_", + "Analysis=",row$description, "_", + "DB=",row$cdmSourceAbbreviation, "_", + Sys.Date()) + } + + return(picName) + + }) + output$downloadSystematicErrorPlotPng <- shiny::downloadHandler( - filename = "SystematicError.png", + + filename = paste0("SystematicErrorPlot_", picName(), ".png"), contentType = "image/png", content = function(file) { ggplot2::ggsave(file, plot = systematicErrorPlot(), width = 12, height = 5.5, dpi = 400) @@ -108,7 +135,7 @@ cohortMethodSystematicErrorServer <- function( ) output$downloadSystematicErrorPlotPdf <- shiny::downloadHandler( - filename = "SystematicError.pdf", + filename = paste0("SystematicErrorPlot_", picName(), ".pdf"), contentType = "application/pdf", content = function(file) { ggplot2::ggsave(file = file, plot = systematicErrorPlot(), width = 12, height = 5.5) @@ -175,7 +202,7 @@ getCohortMethodControlResults <- function( } -plotCohortMethodScatter <- function(controlResults) { +plotCohortMethodScatter <- function(controlResults, ease = NULL) { if(nrow(controlResults)==0){ return(NULL) @@ -262,6 +289,7 @@ plotCohortMethodScatter <- function(controlResults) { labels = breaks) + ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + ggplot2::facet_grid(yGroup ~ Group) + + ggplot2::ggtitle(paste0("EASE Statistic = ", ease)) + ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), panel.background = ggplot2::element_blank(), panel.grid.major = ggplot2::element_blank(), @@ -272,10 +300,60 @@ plotCohortMethodScatter <- function(controlResults) { legend.key = ggplot2::element_blank(), strip.text.x = theme, strip.text.y = theme, - strip.background = ggplot2::element_blank(), - legend.position = "none") + strip.background = ggplot2::element_blank() + # , + # legend.position = "top", + # legend.text = paste0("EASE = ", ease) + ) return(plot) } +estimationGetEase <- function( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = targetId, + comparatorId = comparatorId, + analysisId = analysisId, + databaseId = databaseId +){ + + sql <- " + SELECT DISTINCT + dmd.cdm_source_abbreviation database_name, + cmds.analysis_id, + cmds.target_id, + cmds.comparator_id, + cmds.max_sdm, + cmds.ease + FROM + @schema.@cm_table_prefixdiagnostics_summary cmds + INNER JOIN @schema.@database_table dmd ON dmd.database_id = cmds.database_id + + where cmds.target_id = @target_id + and cmds.comparator_id = @comparator_id + and cmds.analysis_id = @analysis_id + and cmds.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, + analysis_id = analysisId, + database_id = databaseId + ) + + ease <- round(result$ease, 4) + + return( + ease + ) + +} + diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf new file mode 100644 index 0000000000000000000000000000000000000000..0caff5eaa592123cf01cc617f52d1a6b678b45a9 GIT binary patch literal 10146 zcma)C1z42Z)+Q7Lkq!xAL>gg&9J;%^r3M&U7`huNB?W0IL6GiLS~`_31tcY;!GF-> zIp-elz5ku(0cNjnt-aRXe9zkJefOeQk&t2ovvXq82P_Ay1Pld?88~5s0U&^bsWrBM z05(wE31)(TJJ?H@AYcF{2|fr2!U=*xKp?R%!rgClg02 zxS2CR*#+U~f<>mVhM8wa3B@b0Dl?q{AO^icdhLNvq$`)4itB=M<9pJ0Nx+wKsA`N zgNu_Haz4&~%y+HuYdaKR_Lc}M02s^-1^}htwg}`3fKs-|&5?kaIhez)<90?M_skC4 zJ#9co-eH9szhzUqe?%yuk0;NJsOt6&tAI%i&yRCKHmr?Urj*s`HS49jU+JUGS(BQ3 zYcNNs2XHK9d=Ij2%m(;NpX8jtPEZGVp9XP`e!u(Xa_CLyg0Xtj%=fb^jHGk1MR{Dr zERf^e)iqGC@p7uw<*WAI5|N`03EIwAkB1VVV|B1?gMVt5sEN)K!k9$d+zJJ!;e7MN ze)jo(eV_+Ov3v3JQ$jaWUpz5RhIV{7JVh0dVAc?LO2J@?ebBue=8^0f^`?R(o_&3= zW~dP+=o?sME@l81*kB23czY7oyX_i5i4iYcP*(ub-OB%(UO+<{=6Qy->PDt$8_N`= z-nV_Q3YrH8oSVEJEc*Jb^KAP)!@>g1#=T;)u+PuK2G;s4t)EvIU0gn{IPq!q@e~@T zDex%5=LsOdv9hDA=+KR(04E0uva4eUSiOB~_SrCT?#HE*-QpNJ^ z!GSLMVg^Dam9(Y|&O{TAV^DKf2FjN4K-n3kjGoX;GLax306k1Z!%*OcnrYx$m0E@8 z?QdP>$|3#OFPXYous4&Lp5#-!X4dRYqkq9?)ADTS(QZ|UDOJgesMWUe!#1|qB?>m0zJ=z zO=?BDL8ZNXZpZKKEHfje)jZ%sh9eh;;GV`~4mg$fJYMxRCE)m70jjr^-G@+itk%FLo zV8VaQy=CvbgT%jam7K4ZRp^vu&__A{qB}xm(ITwVqWWVA_0K*lw*KXe| zblZ=pC%>7B_s!1;b+)1d*Yc5h^pBMEM@EJInb3Y^)c=|w!Jz*yL;leCXNu(I3kvd1~Ia7JaOMe zYq__$MjgVKT@tH$doAZsNhdz95A(2#zbpJo){`d9ntp!4%}ma7hC4qrdO|ZWjyrPT z{b#ynlP06|3DhofxFMy=V@l)bc&%zwl3G-yn{aPR74V&p+&+dXaJX6RVlaPnT;e1G zonaPE+{8JDL*hnJ&lJ7Q`2ut&oWkCC#(@R#_F22EQCf2E2{A#D1gmhb+qV$-yW}31 z&iVM2D(z889YE}pszjFC`WmnHjq~u{S+F|4a#Fa-qve4Eac?5bTR8^9MjtBcO5Knj zRx4oXPDokfdEaA>*Hg`CY)H%XS|Gl*h)VTURT-&Qg{Bfqxi2x5-o0mDKo=nZo-746 zGpo71Jj*+>fNMeN;Qb|d*6XSliea}dB0tc zgfI0oeVi%cbw5muPYR^qD(wOEMV$dTzGOV_VRE8+4-wj-Nz|@*F~0gQ02XxP7agvM zTY6!gKF=Q41U-S2XQzE2KEuRl>u@~3LKPg*kghreybS1e2H1R{(tRRDIk3fO>xf$= z$64SE?w||XUEv-%de1sSMHrg$qy&r65 zzId{MS0o2U-x#6`k*%b;o0NmoUv>pB3#9L$+r&#WxO)=Pk+6EI&fjC{*}3|i*_^V` zl@ZKBg|Bb8RMuHFpujem64k2_08+PU;~QnJvmd7@zkg6lSzS{;5K3z*xK`F&r)JZ^ zdq70O%~6dJ^>tL^1E~6FS+3+-9>At*BB*ZDk)_Stl&tr_)wO~VIm)NHX_G&RwsNAb z;i75H_Elnn3n|SFRSagWmcrpFe5sr_iPqRlt?*-xj&Lh!Nh+iQ?|Zc9(s4cGH3lyY zYc^27#*uzuHI4H4^iwmet>%;B2Mfs`!@ZAlDbo!Eo23+PhVHIcx4lprl&bYf=9mhP zJvFsG)H7z^XKhZptLi|BR59Wy%=v)!{FUt?#pB|op+gFAqI-7Ehwv0%g;IhULd|HS z2N`l7rAi4NSf}r-a~lU$jMN)V>f&Cx7n+oO1I4g-fPar+CG zu?8!PD{`u>Y&GRl)b@To7o=BnqlpolHVRmC#*R0zmJ;XqOc1)@V^|x(zOk)4jnirZ zeSBqxUlf|~LO7td=dZecZXtlh}9 z2kfDj(tv#dp@ffwwh?Gpz=vRdFk5kzkS`7LehcV;UCmSPwOxG_#rZcEKA2g(GtsRM zC<1hRzC9K;Zm816G0tw;+?1X$U!9Ys{T(Y&#Z?wj5Z~Ti(nGk7eN8!qp2H^C1YHo(bZ)cf!B9!;^c=fQF*KeNHEdgz==qVq}z=MJcD1#>%P+9t+ zV3~mJa(iQjSz`Hs06NEx zJuQXipl(=G7$Vs8>5l5>db4)|3U#k5VHyl`RBxc9+A%M84-J%f@jvhIcgYazJse3S zc7rf-%iz5jHS4swKNwSX3-?ZuZA?Ya8`2wzuR1&MYJ1+i+r^DE-t6fcpshzJx$1sm zn%v?O#M!}TdQbI6PEb^%_SKk+;!_wa$W>Oj7Eh#Js_8k5qazk`)mvhs5cCVzy5WGZH$U`hQ zQFVH0A~djg}~4 zI8&PWm*5wiiAH?#jE9Djli-=*lOTJh6m}HKP$I=0_KKsjv#cRUo+sm5Ih5mgEEPK{ zX3DW4joA}uJk96Nb%eKT&+tO`?_2(Mo`e4aZ2#MVehsPA0RIK@fd2wr*uYijC4#FBU%@63S>`~@?dDD=OJ>m5Hiw z-Ckcr<*4izgdX?pg0gre@K+$ky8tbeY5DdZ&jw z$1Q#bJA}%UMd>W zJx5#T5BG=gDkr~YNZ&|sqL7pTy}!*#Jed4(b3Hhl_$!yL&sHw(&d`C}j>m-X4U%Rz zyqQ6KMP~jUKLk&Di&KenPRo?j8k-9V!SZla~s4VL^LWH0`Fy|$9yciI2GyQB1 zAx2OymW8{+7-D3O9eP&fmV*=o#)uWkW|O77!{2PLQojGj&|i=Y1!4sCa1YEIWhF0K zbsIZXb1x<$3P<(X=w3-Rb4$3zEzfz7{XSh?by&kE+CO}{ z4Aa^p(UrQnN+nIsJ;Rc{{5OxUQV9pzNWGtHcg5H=ggEH9vZ!L6=! zcF02LH!nO)^I&*vu!;rNDTd*rr*4(#kX=zfOvV3&FdKZIKZsLjgeh}vn#RLG$#b*_ z;dt*EsCvY9x+;TV>0Oa(77et9CrEXx%n;0O_R*x3)=s6}-yOVr)=jYUwN8*I4d4Of-XFjra@i*!W zFPg4ee6P@GJ^&wO+CRrsJuCg-q4Y(t03n>cMqN-?pIBP*?Vx?Guh(Gn3YF)%H^J{| z?V8y6i7NiLwDyy@`EP0MTH~KM1uf+*Wic*Y=pmUNA z2c?Sx`kqAhz#pLBJlo{=-g2tbE49)VF?kp=mGYD-j$@%;uZ{keyMJrL!c&@O2B4Xs ziX^Ptp&WBTj{VjrsZSsqPnwKYu}rW%N{W!1z~=2@A>!FGq-m%?ANxxSuKTa z>vqk(oH6psTA5Pz8ceSrquzdZq|~t8gwB_7S+zEs!oO{4c5ceC3w=tU*0p{Lth;5q z(^h^VbVoH|7E&St?JN!)pwwQ{GyD~E^nhUWRAp98x#zy|! zd>Xd`?uU)ne#}_BHw<=f=2XXYE1e<9JVJd;Fvh`VvHZ*sJNx^qIM-KR9Mi4lLsY8jc`ORW`}YYg=xPu@3k={6aNT(%N4=y1R}> z!W5v0bNLn!*&%{O?oEMHA#>+h4?>p~IgXTwYiEd)xuY?J1D2r$-`zRm-F-*$LEpcZ z6ouC4=)xT%NHmc{V$i1jV*Sl4B6Lvt&_`(AMdKJv`5TXZ-zHo?TT< zfA~u`h10+RwKRU+HJ){Bn(}uXjNSF|3B_a6K|<$=<>R|{Zs2%8L=GhtC!PQ@uwIfe z=Hi3Y#|O#7#oC&S1w8GY`$cRM_+VKOnvj)$VlRy6_!M}Va2y* zKit?+$72#VV-WYiXKNn&(p*g;+1`JL`TbsQo}I~LeZ1a_FI0?qhO<#^)FbQTIo}mF zX1}CYQQQ-h<_h2-H)LJ;^5U87WSE89BLa}gtf(OY=>Dv#^6B%h+gYV`k;BN}AD@?P zzbg17-{XqNbOJ6-R|twV(}6SXyfvbNAQ@2@uy#hwil?z)Qc(CRMIH3jt@reK{uI8OsY6YFqH@Iw8aCt!=wV2r4!c3Sqch#NUz?_5ZiCT z;bD}gjMiaEN!)dk`q=z-j!%58tX^Lwt%v#6SUWH`Rtc1z9TL72I;Fe4m05fv_34%8 zw;lEmTXRQPxX0g%9}_XP4Qzbq-oD)4dE6NEG&6JA@%yEP;ALiypRZ9ZlxxZ$!5K3^ zAk|qWO<{TGQHB3%>2F!{-zQCH08k!o?hMceT(je9fNKg!4M}7F{PUARH$*b)4lYQB z99iZm!pz|&Vh-*A{cG}v3&eT-WB50c{qLC+$>p1=!w>*{Ao4Z=nW|y#2t#b36p~;E z2nYbBAOJA;4?jq594P6IkXA=rUnU3$0D#i!U;y}MM9A+*#Xrb+=k(VC&$d?r386(}S~`v>1Tvm;1ji39d!gCxJdt zR$N@n#2ID|_z|SxuWN_v(XYct^qS|lzYZEG0ds|$!LBC-Dj}~Deig^akp4Z}b-iVO zUI?ToxoN0Rk%kR5^E9i(;YTD4+gPcg$=qp{iDhR2W8urSJwu`8me6pNP>s#M1z}qB z&k>I;r;P|fRW0AVK`t@=*pZkrN!GlCe4)u>cOZ3v=GfOJvw3LFa@S|F0p;06(9L%W zI#~WV**e5aYn|cIk(S1os5oCy&}~r`9V;uvNKd5DQqa6VM%ktioscy*-~vw1S;mB; z-lBZZOsLnT1*51WN3HFjOc{`q_3{d8r_t9c_a@hHDh`6=25EHzAzJay`w#WKk5XWG z&;v-Y0C}JD;4dPoa{Sr9@tRHVz{Q#rY}5;qD{+${U5 zv%0x0n^_zaB#>>z17%UB_tDo;pich~Q6FCCV80$aAzeW@IfH?EXmmVL9 zKM0p6`oS{zV+y%0)shp6#n6Q=v4yc}(5lZKT$*{Lqs1_3W&H zJZh#5GjM(PEECsH{E_#NTFcz-XA}2>c-}Y!Slo!m-oi6qqN8VU+3^%-H8bpl2J^~= znv~#zt|c6pASuz8uK-X;s@Crz3cr~m7AkU*`Qikx{VI2=KIzHy3BhoZ4qD!Q3K3sw z6ebn|0G5|I>+r76?JjBb(}Bp5l;rgDp};F2?K*|49#T5L7&B=JNFAZ-;MR)^Jv2@L zilhkoh6v?4I#Jt=nl^$u6ud=rG*PDT8;^~_i-E+?P$d9l#QxP;cM}3jj2T~HxMUG< z25~#yMFf~Fa`Ixb2lN@=m_=0s;b!!4D4U!6#7*Ljc5ks47Bqo>6{6zbQ_j zLX~ifUR+EDjYMQKOYId^QRqgt#k&4F6M~`v<&Jo5mZ}xu8Hp$60}xjJTfH&@+nbff z%DlH?g2~?YeuePTum{$*B|4&ewHa}z)2YnV7F>hvh3`e^b(25FC+NX4!m)<;k%53xIBSRI zqMjq8qqZYa9eESsJpOJJUgyErzCGB9lsBI5E#a8V`%FYpSZ{)5#8^z&vg3xOc;)Nl z-9_mLzlAGxIKK3+3)PVokPuL&qHm#Bm9e1XW)7gcZ+Cy2F`agfwiyuLD`k%7B%rG> zFJ{k>d4GYiRW*x6hvf#-S7I&JaV7+dfvS6cxHhN8p@uF_5lrVymP}?E!9~h2_4;v_ zaj6a64c2g(a8FJC@ACoZO%cdMbU;lClIWswPIpf!4 z(^S@M*X1eeRD3w^`4hM)!x&n{0@&k)aT&*MX^vxk>- zm-o(^&(tyaFz#dA#3;e2y|Wkku${QwF!VCCG&(BUG>ZGK3%MXfivt%l$YamdVk5@= zm`B%Q)Yxf&*z7$-kz>xza|(yMl1Co=8cYcZ8@ShhbG30GjBS`yiBv2SBa%{qa4bHh z-4+(3H_8^ocAKs7VWuv*PN%+I|mmAciK*}?0Q6t)jFT}RUf z`vwd3uh(3MeC#dlyK866+{QAjX-r$+wtTn>3d#xU$sRBn9ccrPluzzqM0R1D*;%B! ziSc_tOI-O@4=1PI>TY>|JS8K`mwzE2*_Y$db#QV(u@+swQSW51X_#k^Q!7#1Y_H~K z=oaG@bdHYagO?#4-yK{~Xj!x-I%H`yX+&F!Tl&G)@<{H8*`Z@*sIkLqIBc2dv--C4 zg7y&4RPBV@`=NPY>j1ulg5?bhjl2_=x6a-4vY=#S0t=lzc0A z-%-Z6=jd7E!JW0+Yi=Qd!~VnD*~jmq+LJyDO0*A^XxZha`vSWopi&ZujnlZW*%@Q|&IJh_P^@4wr7Tm7JB-<@?#Adf_$uVNHxa+B&@Q(GNLlKFYWoZ0XIE1As0-1Dzc)nlXGfl+`mJj!U*zW zB}qO0fPshaSSG_M1LR;_Keeye$GGov&}tN*_ttPkKTE%?#u$;e_Wn$BxG3+nr}kzk zyPjZ6m%~6nb#OJ@#*e9r{UOl1p54MwIaX`r#mn+B;0vvkw7j zW~eKgoiWX%dt;vSKi_InG0|47jVzO|kk=zOm@H*nTaFPl?X^`+f+$@fb@ zIJ(b3%)kKK3pQAZ-V=I7+`Avq>#P;a*kSoma5p)wg?0GbX6zZ1CBA3hUjImqeLL ztC?v+i7p#ozI+-pYnJ!iO?x8fTmo!z_-Z>mb+G0=l>X&-OW0%n+eP{9L9!SlbHlBM zPmYDoZN6D6nCCQn822#v!>Gah3r9HlD6)ot3QBI@=G;>N=D8)PBksZH_p9aZKsUd0B3_0T2}05aj!6{5FW+Y_^pv1w08R>2YA4Z_C(TV$o>|}gOL8mb5cZ2i(Pg8EK?iUac2|w4B z!QsVNY3id_tslRS?!a~t9}h3J$xAJao;RubIWMwp+I??Kb|d1b-!0!|6;AeDKfQan zw^It7>nxV@;oGyInT8z=#{ zuz(?ZUap&3^Z}e)Ks&g-i!;FRZ_PD7D)V1u?$7Ce)a^iZ7gNNKW}9mvve!k)#12{g zB5U~{PJimiz-(P%2)LOEvaJ6V(~o%n-i`C4y#K|y{IP&v7ywzVivqyxAQ0$p$l?bE z_-_UvcHVzA`0GCV&n^1PgP92c#17#C|83Dfki>uVfHe3K(%%jKBG~_v2M!SA?*@P8 z&wpF=kC2dS_?v;d6U+h|iDNjhk(=?y2f)q6#lZ!z0Q@Pt20hmwfc>8`FgFss{i}={ z1VzHAf5;%9-)y-#pugL4LXg1cUu{8<>+67j%Ami=z+4dI%lfZ+U~bTF^KtweJq~UV z5(fUOEhi5*5@r5FcHLF*4;d8v`@TRS*KhW}+Cn+Nzs(2b_Vi+