Merge pull request #218 from OHDSI/develop

Develop

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: OhdsiShinyModules
 Type: Package
 Title: Repository of Shiny Modules for OHDSI Result Viewers
-Version: 2.0.0
+Version: 2.0.2
 Author: Jenna Reps
 Maintainer: Jenna Reps <reps@ohdsi.org>
 Description: Install this package to access useful shiny modules for building shiny apps to explore results using the OHDSI tools .

NEWS.md

@@ -1,3 +1,14 @@
+OhdsiShinyModules v2.0.2
+========================
+edited characterization server to work with new aggregate features method in characterization package
+edited characterization server to work when one or more characterization result is missing
+edited evidence synth module to highlight the bayesian and fix issue with comparison names not showing
+
+OhdsiShinyModules v2.0.1
+========================
+Bug Fixes:
+- Fix for CohortDiagnostic app not loading when characterization was set to FALSE
+
 OhdsiShinyModules v2.0.0
 ========================
 - updated all models to use the same resultDatabaseSettings

R/characterization-aggregateFeatures.R

@@ -91,7 +91,6 @@ characterizationAggregateFeaturesViewer <- function(id) {
 #'
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
-#' @param mainPanelTab the current tab 
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
 #' 
 #' @return
@@ -101,7 +100,6 @@ characterizationAggregateFeaturesViewer <- function(id) {
 characterizationAggregateFeaturesServer <- function(
     id, 
     connectionHandler,
-    mainPanelTab,
     resultDatabaseSettings
 ) {
   shiny::moduleServer(

R/characterization-cohorts.R

@@ -62,7 +62,6 @@ characterizationTableViewer <- function(id) {
 #'
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
-#' @param mainPanelTab the current tab
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
 #'
 #' @return
@@ -72,7 +71,6 @@ characterizationTableViewer <- function(id) {
 characterizationTableServer <- function(
     id,
     connectionHandler,
-    mainPanelTab,
     resultDatabaseSettings
 ) {
   shiny::moduleServer(

R/characterization-dechallengeRechallenge.R

@@ -60,7 +60,6 @@ characterizationDechallengeRechallengeViewer <- function(id) {
 #'
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
-#' @param mainPanelTab the current tab 
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
 #' 
 #' @return
@@ -70,7 +69,6 @@ characterizationDechallengeRechallengeViewer <- function(id) {
 characterizationDechallengeRechallengeServer <- function(
   id, 
   connectionHandler,
-  mainPanelTab,
   resultDatabaseSettings
 ) {
   shiny::moduleServer(

R/characterization-incidence.R

@@ -216,7 +216,6 @@ characterizationIncidenceViewer <- function(id) {
 #'
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
-#' @param mainPanelTab the current tab
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
 #' 
 #' @return
@@ -226,7 +225,6 @@ characterizationIncidenceViewer <- function(id) {
 characterizationIncidenceServer <- function(
     id, 
     connectionHandler,
-    mainPanelTab,
     resultDatabaseSettings
 ) {
   shiny::moduleServer(

R/characterization-main.R

@@ -52,33 +52,8 @@ characterizationViewer <- function(id=1) {
 
   shiny::tabsetPanel(
     type = 'pills',
-    id = ns('mainPanel'),
-
-    shiny::tabPanel(
-      "Target Viewer",  
-      characterizationTableViewer(ns('descriptiveTableTab'))
-    ),
-
-    shiny::tabPanel(
-      "Outcome Stratified",  
-      characterizationAggregateFeaturesViewer(ns('aggregateFeaturesTab'))
-    ),
-
-    shiny::tabPanel(
-      "Incidence Rate",  
-      characterizationIncidenceViewer(ns('incidenceTab'))
-    ),
-
-    shiny::tabPanel(
-      "Time To Event",  
-      characterizationTimeToEventViewer(ns('timeToEventTab'))
-    ),
-
-    shiny::tabPanel(
-      "Dechallenge Rechallenge",
-      characterizationDechallengeRechallengeViewer(ns('dechallengeRechallengeTab'))
-      )
-    )
+    id = ns('mainPanel')
+  )
   )
 
 }
@@ -104,71 +79,168 @@ characterizationServer <- function(
   shiny::moduleServer(
     id,
     function(input, output, session) {
+
+      # this function checks tables exist for the tabs
+      # and returns the tabs that should be displayed
+      # as the tables exist
+      charTypes <- getCharacterizationTypes(
+        connectionHandler = connectionHandler,
+        resultDatabaseSettings = resultDatabaseSettings
+      )
 
-      mainPanelTab <- shiny::reactiveVal(input$mainPanel)
-      shiny::observeEvent(
-        input$mainPanel,
-        {
-          mainPanelTab(input$mainPanel)
-        })
+      # add the tabs based on results
+      types <- list(
+        c("Target Viewer","characterizationTableViewer", "descriptiveTableTab"),
+        c("Outcome Stratified", "characterizationAggregateFeaturesViewer", "aggregateFeaturesTab"),
+        c("Incidence Rate", "characterizationIncidenceViewer", "incidenceTab"),
+        c("Time To Event", "characterizationTimeToEventViewer", "timeToEventTab"),
+        c("Dechallenge Rechallenge", 'characterizationDechallengeRechallengeViewer', 'dechallengeRechallengeTab')
+        )
+      selectVal <- T
+      for( type in types){
+        if(type[1] %in% charTypes){
+          shiny::insertTab(
+            inputId = "mainPanel",
+            tab = shiny::tabPanel(
+              type[1],  
+              do.call(what = type[2], args = list(id = session$ns(type[3])))
+            ), 
+            select = selectVal
+          )
+        }
+        selectVal = F
+      }
+
+      previouslyLoaded <- shiny::reactiveVal(c())
 
+      # only render the tab when selected
+      shiny::observeEvent(input$mainPanel,{
 
       # =============================
       #   Table of cohorts
       # =============================
-      characterizationTableServer(
-        id = 'descriptiveTableTab',
-        connectionHandler = connectionHandler, 
-        mainPanelTab = mainPanelTab,
-        resultDatabaseSettings = resultDatabaseSettings
-        )
+        if(input$mainPanel == "Target Viewer"){
+          if(!"Target Viewer" %in% previouslyLoaded()){
+            characterizationTableServer(
+              id = 'descriptiveTableTab',
+              connectionHandler = connectionHandler, 
+              resultDatabaseSettings = resultDatabaseSettings
+            )
+            previouslyLoaded(c(previouslyLoaded(), "Target Viewer"))
+          }
+        }
 
 
       # =============================
       #   Aggregrate Features
       # =============================
-
-      characterizationAggregateFeaturesServer(
-        id = 'aggregateFeaturesTab',
-        connectionHandler = connectionHandler, 
-        mainPanelTab = mainPanelTab,
-        resultDatabaseSettings = resultDatabaseSettings
-        )
+        if(input$mainPanel == "Outcome Stratified"){
+          if(!"Outcome Stratified" %in% previouslyLoaded()){
+            characterizationAggregateFeaturesServer(
+              id = 'aggregateFeaturesTab',
+              connectionHandler = connectionHandler, 
+              resultDatabaseSettings = resultDatabaseSettings
+            )
+            previouslyLoaded(c(previouslyLoaded(), "Outcome Stratified"))
+          }
+        }
 
       # =============================
       #   Incidence
       # =============================
-      characterizationIncidenceServer(
-        id = 'incidenceTab',
-        connectionHandler = connectionHandler, 
-        mainPanelTab = mainPanelTab,
-        resultDatabaseSettings = resultDatabaseSettings
-        )
+        if(input$mainPanel == "Incidence Rate"){
+          if(!"Incidence Rate" %in% previouslyLoaded()){
+            characterizationIncidenceServer(
+              id = 'incidenceTab',
+              connectionHandler = connectionHandler, 
+              resultDatabaseSettings = resultDatabaseSettings
+            )
+            previouslyLoaded(c(previouslyLoaded(), "Incidence Rate"))
+          }
+        }
 
 
       # =============================
       #   Time To Event
       # =============================
-
-      characterizationTimeToEventServer(
-          id = 'timeToEventTab', 
-          connectionHandler = connectionHandler, 
-          mainPanelTab = mainPanelTab,
-          resultDatabaseSettings = resultDatabaseSettings
-         )
-
+        if(input$mainPanel == "Time To Event"){
+          if(!"Time To Event" %in% previouslyLoaded()){
+            characterizationTimeToEventServer(
+              id = 'timeToEventTab', 
+              connectionHandler = connectionHandler, 
+              resultDatabaseSettings = resultDatabaseSettings
+            )
+            previouslyLoaded(c(previouslyLoaded(), "Time To Event"))
+          }
+        }
 
       # =============================
       #   Dechallenge Rechallenge
       # =============================
-
-      characterizationDechallengeRechallengeServer(
-        id = 'dechallengeRechallengeTab', 
-        connectionHandler = connectionHandler, 
-        mainPanelTab = mainPanelTab,
-        resultDatabaseSettings = resultDatabaseSettings
-        )
+        if(input$mainPanel == "Dechallenge Rechallenge"){
+          if(!"Dechallenge Rechallenge" %in% previouslyLoaded()){
+            characterizationDechallengeRechallengeServer(
+              id = 'dechallengeRechallengeTab', 
+              connectionHandler = connectionHandler, 
+              resultDatabaseSettings = resultDatabaseSettings
+            )
+            previouslyLoaded(c(previouslyLoaded(), "Dechallenge Rechallenge"))
+          }
+        }
+
+      }) # end observed input tab
 
     }
   )
 }
+
+getCharacterizationTypes <- function(
+    connectionHandler,
+    resultDatabaseSettings
+){
+
+  results <- c()
+
+  conn <- DatabaseConnector::connect(
+    connectionDetails = connectionHandler$connectionDetails
+    )
+  on.exit(DatabaseConnector::disconnect(conn))
+  tbls <- DatabaseConnector::getTableNames(
+    connection = conn,
+    databaseSchema = resultDatabaseSettings$schema
+  )
+
+  # check Targets
+  if(sum(paste0(
+    resultDatabaseSettings$cTablePrefix,
+    c('covariates', 'covariate_ref', 'cohort_details', 'settings')
+  ) %in% tbls) == 4){
+    results <- c(results, "Target Viewer", "Outcome Stratified" )
+  }
+
+  # check dechallenge_rechallenge
+  if(paste0(
+    resultDatabaseSettings$cTablePrefix,
+    'dechallenge_rechallenge'
+  ) %in% tbls){
+    results <- c(results, "Dechallenge Rechallenge")
+  }
+
+  # check time_to_event
+  if(paste0(
+    resultDatabaseSettings$cTablePrefix,
+    'time_to_event'
+  ) %in% tbls){
+    results <- c(results, "Time To Event")
+  }
+
+  # check incidence
+  if(paste0(
+    resultDatabaseSettings$incidenceTablePrefix,
+    'incidence_summary'
+  ) %in% tbls){
+    results <- c(results, "Incidence Rate")
+  }
+
+  return(results)
+}

R/characterization-timeToEvent.R

@@ -75,7 +75,6 @@ characterizationTimeToEventViewer <- function(id) {
 #'
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
-#' @param mainPanelTab the current tab 
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
 #' 
 #' @return
@@ -85,17 +84,12 @@ characterizationTimeToEventViewer <- function(id) {
 characterizationTimeToEventServer <- function(
   id, 
   connectionHandler,
-  mainPanelTab,
   resultDatabaseSettings
 ) {
   shiny::moduleServer(
     id,
     function(input, output, session) {
 
-      #if(mainPanelTab() != 'Time To Event'){
-      #  return(invisible(NULL))
-      #}
-
       # get the possible target ids
       bothIds <- timeToEventGetIds(
         connectionHandler,

R/cohort-diagnostics-main.R

@@ -235,14 +235,16 @@ createCdDatabaseDataSource <- function(
   dataSource$temporalAnalysisRef <- loadResultsTable(dataSource, "temporal_analysis_ref", cdTablePrefix = dataSource$cdTablePrefix)
 
   dataSource$temporalChoices <- getResultsTemporalTimeRef(dataSource = dataSource)
-  dataSource$temporalCharacterizationTimeIdChoices <- dataSource$temporalChoices %>%
-    dplyr::arrange(sequence)
 
-  dataSource$characterizationTimeIdChoices <- dataSource$temporalChoices %>%
-    dplyr::filter(.data$isTemporal == 0) %>%
-    dplyr::filter(.data$primaryTimeId == 1) %>%
-    dplyr::arrange(.data$sequence)
+  if (hasData(dataSource$temporalChoices)) {
+    dataSource$temporalCharacterizationTimeIdChoices <- dataSource$temporalChoices %>%
+      dplyr::arrange(.data$sequence)
 
+    dataSource$characterizationTimeIdChoices <- dataSource$temporalChoices %>%
+      dplyr::filter(.data$isTemporal == 0) %>%
+      dplyr::filter(.data$primaryTimeId == 1) %>%
+      dplyr::arrange(.data$sequence)
+  }
 
   if (!is.null(dataSource$temporalAnalysisRef)) {
     dataSource$temporalAnalysisRef <- dplyr::bind_rows(