Merge pull request #360 from OHDSI/develop

Release 3.1.0

.gitignore

@@ -5,3 +5,4 @@
 /.idea/
 rsconnect/rconnect.jnj.com/NHall6/phevaluator_v01.dcf
 errorReportSql.txt
+tests/testthat/Rplots.pdf

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: OhdsiShinyModules
 Type: Package
 Title: Repository of Shiny Modules for OHDSI Result Viewers
-Version: 3.0.2
+Version: 3.1.0
 Authors@R: c(
   person("Jenna", "Reps", email = "[email protected]", role = c("aut", "cre")),
   person("Nathan", "Hall", role = c("aut")),

NEWS.md

@@ -1,3 +1,10 @@
+OhdsiShinyModules v3.1.0
+========================
+- Removed percentage calculation from records field in CohortDiagnostics
+- Updated the About module to reflect new module names and structure
+- Updated module description vignette files to reflect new module names and structure
+- Added interactive scatterplots for binary covariates when doing database and cohort comparisons in Characterization
+
 OhdsiShinyModules v3.0.2
 ========================
 - Fixed bug with orphan concepts not loading

R/about-main.R

@@ -65,10 +65,12 @@ aboutViewer <- function(id = 'homepage') {
       shinydashboard::valueBoxOutput(ns("cohortDiagnosticsBox"), width = 3)
     ),
     shiny::fluidRow(
-      shinydashboard::valueBoxOutput(ns("cohortMethodBox"), width = 3),
+      shinydashboard::valueBoxOutput(ns("estimationBox"), width = 3),
       shinydashboard::valueBoxOutput(ns("predictionBox"), width = 3),
-      shinydashboard::valueBoxOutput(ns("sccsBox"), width = 3),
-      shinydashboard::valueBoxOutput(ns("evidenceSynthesisBox"), width = 3)
+      shinydashboard::valueBoxOutput(ns("reportGeneratorBox"), width = 3)
+      # ,
+      # shinydashboard::valueBoxOutput(ns("sccsBox"), width = 3),
+      # shinydashboard::valueBoxOutput(ns("evidenceSynthesisBox"), width = 3)
     )
   )
 }
@@ -127,7 +129,7 @@ aboutServer <- function(id = 'homepage',
                                 value = "Data Sources",
                                 subtitle = "Data sources used in this analysis",
                                 icon = shiny::icon("database"),
-                                color = "aqua",
+                                color = "olive",
                                 href = "https://ohdsi.github.io/OhdsiShinyModules/articles/DataSources.html"
                               )
                             } else {
@@ -169,7 +171,7 @@ aboutServer <- function(id = 'homepage',
                                 value = "Characterization",
                                 subtitle = "Characterization results for this analysis",
                                 icon = shiny::icon("table"),
-                                color = "teal",
+                                color = "red",
                                 href = "https://ohdsi.github.io/OhdsiShinyModules/articles/Characterization.html"
                               )
                             } else {
@@ -205,23 +207,23 @@ aboutServer <- function(id = 'homepage',
                           })
 
 
-                        output$cohortMethodBox <-
+                        output$estimationBox <-
                           shinydashboard::renderValueBox({
-                            if ("CohortMethod" %in% tab_names) {
+                            if ("Estimation" %in% tab_names) {
                               targetedValueBox(
-                                value = "Cohort Method",
-                                subtitle = "Cohort Method results for this analysis",
+                                value = "Estimation",
+                                subtitle = "Population-level effect estimation results for this analysis",
                                 icon = shiny::icon("chart-column"),
                                 color = "maroon",
-                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/CohortMethod.html"
+                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/Estimation.html"
                               )
                             } else {
                               targetedValueBox(
-                                value = "Cohort Method",
+                                value = "Estimation",
                                 subtitle = "This module was not included in this analysis",
                                 icon = shiny::icon("chart-column"),
                                 color = "black",
-                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/CohortMethod.html"
+                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/Estimation.html"
                               )
                             }
                           })
@@ -231,7 +233,7 @@ aboutServer <- function(id = 'homepage',
                             if ("Prediction" %in% tab_names) {
                               targetedValueBox(
                                 value = "Prediction",
-                                subtitle = "Patient-level Prediction results for this analysis",
+                                subtitle = "Patient-level prediction results for this analysis",
                                 icon = shiny::icon("chart-line"),
                                 color = "blue",
                                 href = "https://ohdsi.github.io/OhdsiShinyModules/articles/Prediction.html"
@@ -290,5 +292,27 @@ aboutServer <- function(id = 'homepage',
                             }
                           })
 
+                        output$reportGeneratorBox <-
+                          shinydashboard::renderValueBox({
+                            if ("Report" %in% tab_names) {
+                              targetedValueBox(
+                                value = "Report",
+                                subtitle = "Report Generator for this analysis",
+                                icon = shiny::icon("book"),
+                                color = "teal",
+                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/ReportGenerator.html"
+                              )
+                            } else {
+                              targetedValueBox(
+                                value = "Report",
+                                subtitle =
+                                  "This module was not included in this analysis",
+                                icon = shiny::icon("book"),
+                                color = "black",
+                                href = "https://ohdsi.github.io/OhdsiShinyModules/articles/ReportGenerator.html"
+                              )
+                            }
+                          })
+
                       })
 }

R/characterization-cohorts.R

@@ -49,7 +49,20 @@ characterizationCohortComparisonViewer <- function(id) {
           ),
           shiny::tabPanel(
             title = 'Binary',
-            resultTableViewer(id = ns('mainTable'), boxTitle = 'Binary')
+            shiny::tabsetPanel(
+              type = 'pills',
+              id = ns('binaryPanel'),
+              shiny::tabPanel(
+                title = "Table",
+                resultTableViewer(id = ns('mainTable'), boxTitle = 'Binary')
+              ),
+              shiny::tabPanel(
+                title = "Plot",
+                shinycssloaders::withSpinner(
+                  plotly::plotlyOutput(ns('scatterPlot'))
+                )
+              )
+            )
           ),
           shiny::tabPanel(
             title = 'Continuous',
@@ -281,9 +294,80 @@ characterizationCohortComparisonServer <- function(
               elementId = session$ns('count-table-filter')
             ),
             elementId = session$ns('count-table-filter')
-          )} 
+          )
+
+        }
+
+        #scatterplots
+
+        plotDf <- shiny::reactive({
+
+          # Get the filtered and processed plot data
+          plotData <- resultTable %>%
+            replace(is.na(.), 0) %>%
+            dplyr::mutate(domain = dplyr::case_when(
+              grepl("condition_", covariateName) | sub("\\s.*", "", covariateName) == "condition" ~ "Condition",
+              grepl("drug_", covariateName) | sub("\\s.*", "", covariateName) == "drug" ~ "Drug",
+              grepl("procedure_", covariateName) | sub("\\s.*", "", covariateName) == "procedure" ~ "Procedure",
+              grepl("measurement_", covariateName) | sub("\\s.*", "", covariateName) == "measurement" ~ "Measurement",
+              grepl("observation_", covariateName) | sub("\\s.*", "", covariateName) == "observation" ~ "Observation",
+              grepl("device_", covariateName) | sub("\\s.*", "", covariateName) == "device" ~ "Device",
+              grepl("cohort_", covariateName) | sub("\\s.*", "", covariateName) == "cohort" ~ "Cohort",
+              grepl("visit_", covariateName) | sub("\\s.*", "", covariateName) == "visit" ~ "Visit",
+              .default = "Demographic"
+            ))
+
+          # Create hover text for plotly
+          plotData$hoverText <- paste(
+            "Covariate Name:", plotData$covariateName, 
+            "<br>", "Target", ":", scales::percent(plotData$averageValue_1), 
+            "<br>", "Comparator", ":", scales::percent(plotData$averageValue_2)
+          )
+
+          #removing negatives, which come from "< min threshold"
+          plotData$averageValue_1[plotData$averageValue_1 < 0] <- 0
+          plotData$averageValue_2[plotData$averageValue_2 < 0] <- 0
+
+          return(plotData)
+
+        })
+
+         shiny::observe({
+            output$scatterPlot <- plotly::renderPlotly({
+
+              plotData <- plotDf()
+
+              # Create the scatter plot with the diagonal line (x = y)
+              p <- ggplot2::ggplot(plotData, ggplot2::aes(       x = .data$averageValue_1,
+                                                                 y = .data$averageValue_2,
+                                                                 color = .data$domain,
+                                                                 text = .data$hoverText)) +  # Use hoverText for hover labels
+                ggplot2::geom_point(size = 2) +    # Smaller point size
+                ggplot2::geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "black") +  # Diagonal x=y line in black
+                ggplot2::labs(
+                  x = paste0("Target", " %"),
+                  y = paste0("Comparator", " %"),
+                  color = "Domain",
+                  title = paste0("Database: ", names(inputVals()$databaseIds)[input$databaseId == inputVals()$databaseIds])
+                ) +
+                ggplot2::theme_minimal() +          # Optional: use a clean theme
+                ggplot2::theme(
+                  plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10), hjust = 0.5, size = 25, face="bold"),
+                  legend.position = "right",        # Position legend as needed
+                  axis.title = ggplot2::element_text(size = 12),  # Adjust axis title size
+                  axis.text = ggplot2::element_text(size = 10)    # Adjust axis text size
+                ) +
+                ggplot2::scale_x_continuous(labels = scales::percent_format()) +  # Format x-axis as percentage
+                ggplot2::scale_y_continuous(labels = scales::percent_format())    # Format y-axis as percentage
+
+              # Convert to a plotly object for interactivity
+              plotly::ggplotly(p, tooltip = "text")  # Use the custom hover text
+            })
+          })
 
       })
+
+
 
       return(invisible(NULL))
 
@@ -777,7 +861,7 @@ characterizatonGetCohortData <- function(
   }
 
   shiny::withProgress(message = 'characterizatonGetCohortData', value = 0, {
-    
+
     shiny::incProgress(1/4, detail = paste("Setting types"))
 
     types <- data.frame(
@@ -862,13 +946,15 @@ characterizatonGetCohortData <- function(
         result <- result %>% dplyr::select(-"firstVar",-"secondVar", -"N_1", -"N_2")
 
       } else{
+        NULL
         shiny::showNotification('Unable to add SMD due to missing columns')
       }
     }
     shiny::incProgress(4/4, detail = paste("Done"))
   })
 
-  return(result)
+    return(result)
+
 }
 
 
@@ -1014,3 +1100,61 @@ characterizationGetCohortsInputs <- function(
     )
   )
 }
+
+characterizationGetCohortComparisonDataRaw <- function(
+    connectionHandler,
+    resultDatabaseSettings,
+    targetIds,
+    databaseIds,
+    minThreshold = 0.01,
+    addSMD = F
+){
+
+  if(is.null(targetIds) |  is.null(databaseIds)){
+    warning('Ids cannot be NULL')
+    return(NULL)
+  }
+
+  sql <- "select  d.cdm_source_abbreviation,
+          ref.covariate_name, 
+          s.min_prior_observation,
+          cov.target_cohort_id as cohort_definition_id,
+          cg.cohort_name,
+          cov.* from   
+    @schema.@c_table_prefixCOVARIATES cov 
+    inner join 
+    @schema.@c_table_prefixcovariate_ref ref
+    on cov.covariate_id = ref.covariate_id
+    and cov.setting_id = ref.setting_id
+    and cov.database_id = ref.database_id
+    inner join 
+    @schema.@c_table_prefixsettings s
+    on s.database_id = cov.database_id
+    and s.setting_id = cov.setting_id
+    inner join 
+    @schema.@database_table d
+    on cov.database_id = d.database_id
+    inner join
+    @schema.@cg_table_prefixcohort_definition cg
+    on cov.target_cohort_id = cg.cohort_definition_id
+    
+    where 
+    cov.target_cohort_id in (@target_ids) 
+    and cov.cohort_type = 'Target'
+    AND cov.database_id in (@database_ids)
+    AND cov.average_value >= @min_threshold;"
+
+  # settings.min_characterization_mean needed?
+  res <- connectionHandler$queryDb(
+    sql = sql,
+    target_ids = paste0(targetIds, collapse = ','),
+    database_ids = paste0("'",databaseIds,"'", collapse = ','),
+    schema = resultDatabaseSettings$schema,
+    c_table_prefix = resultDatabaseSettings$cTablePrefix,
+    min_threshold = minThreshold,
+    database_table = resultDatabaseSettings$databaseTable,
+    cg_table_prefix = resultDatabaseSettings$cgTablePrefix
+  )
+
+  return(res)
+}