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 #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 <[email protected]> * fixing testing errors --------- Co-authored-by: jreps <[email protected]>
OHDSI · Sep 20, 2024 · 0d8f845 · 0d8f845
1 parent 258a786
commit 0d8f845
Show file tree

Hide file tree

Showing 8 changed files with 480 additions and 55 deletions.
diff --git 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
@@ -112,6 +112,7 @@ cohortMethodCovariateBalanceServer <- function(
           analysisId = row$analysisId)},
           error = function(e){return(data.frame())}
         )
+
         return(balance)
       })
 
@@ -127,14 +128,31 @@ 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 {
           plot <- plotCohortMethodCovariateBalanceScatterPlotNew(
             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 <- "<strong>Figure 3.</strong> 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
+  )
+
+}
+