Merge branch 'develop' into cd-submenu-items

OHDSI · Sep 14, 2023 · 28fd998 · 28fd998
2 parents fd48ba8 + a1f36db
commit 28fd998
Show file tree

Hide file tree

Showing 46 changed files with 2,282 additions and 2,419 deletions.
diff --git a/R/characterization-aggregateFeatures.R b/R/characterization-aggregateFeatures.R
diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R
diff --git a/R/characterization-dechallengeRechallenge.R b/R/characterization-dechallengeRechallenge.R
diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R
diff --git a/R/characterization-timeToEvent.R b/R/characterization-timeToEvent.R
@@ -32,28 +32,17 @@ characterizationTimeToEventViewer <- function(id) {
   ns <- shiny::NS(id)
   shiny::div(
 
-    shinydashboard::box(
-      collapsible = TRUE,
-      collapsed = TRUE,
-      title = "Time-to-events",
-      width = "100%",
-      shiny::htmlTemplate(system.file("characterization-www", "help-timeToEvent.html", package = utils::packageName()))
-    ),
-
-    shinydashboard::box(
-      width = "100%",
-      title = 'Options',
-      collapsible = TRUE,
-      collapsed = F,
-      shiny::uiOutput(ns('timeToEventInputs'))
+    infoHelperViewer(
+      id = "helper",
+      helpLocation= system.file("characterization-www", "help-timeToEvent.html", package = utils::packageName())
     ),
 
+    # input component module
+    inputSelectionViewer(id = ns('input-selection')),
 
     shiny::conditionalPanel(
-      condition = "input.generate != 0",
-      ns = ns,
-
-      shiny::uiOutput(ns("TTEinputsText")),
+      condition = 'input.generate != 0',
+      ns = shiny::NS(ns("input-selection")),
 
       shinydashboard::box(
         width = "100%",
@@ -113,134 +102,66 @@ characterizationTimeToEventServer <- function(
         resultDatabaseSettings
       )
 
-      shiny::observeEvent(
-        input$targetId,{
-          val <- bothIds$outcomeIds[[which(names(bothIds$outcomeIds) == input$targetId)]]
-          shiny::updateSelectInput(
-            session = session,
-            inputId = 'outcomeId', 
-            label = 'Outcome id: ',
-            choices = val
-          )
-        }
-      )
 
-      # update UI
-      output$timeToEventInputs <- shiny::renderUI({
-
-        shiny::fluidPage(
-          shiny::fluidRow(
-
-            shiny::column(
-              width = 6,
-              shinyWidgets::pickerInput(
-                inputId = session$ns('targetId'), 
-                label = 'Target id: ', 
-                choices = bothIds$targetIds, 
-                multiple = FALSE,
-                choicesOpt = list(style = rep_len("color: black;", 999)),
-                selected = 1,
-                options = shinyWidgets::pickerOptions(
-                  actionsBox = TRUE,
-                  liveSearch = TRUE,
-                  size = 10,
-                  liveSearchStyle = "contains",
-                  liveSearchPlaceholder = "Type here to search",
-                  virtualScroll = 50
-                )
-              )
-            ),
-            shiny::column(
-              width = 6,
-              shinyWidgets::pickerInput(
-                inputId = session$ns('outcomeId'), 
-                label = 'Outcome id: ', 
-                choices = bothIds$outcomeIds[[1]],
-                selected = 1,
-                choicesOpt = list(style = rep_len("color: black;", 999)),
-                options = shinyWidgets::pickerOptions(
-                  actionsBox = TRUE,
-                  liveSearch = TRUE,
-                  size = 10,
-                  liveSearchStyle = "contains",
-                  liveSearchPlaceholder = "Type here to search",
-                  virtualScroll = 50
-                )
+      # input selection component
+      inputSelected <- inputSelectionServer(
+        id = "input-selection", 
+        inputSettingList = list(
+          createInputSetting(
+            rowNumber = 1,                           
+            columnWidth = 6,
+            varName = 'targetId',
+            uiFunction = 'shinyWidgets::pickerInput',
+            uiInputs = list(
+              label = 'Target: ',
+              choices = bothIds$targetIds,
+              #choicesOpt = list(style = rep_len("color: black;", 999)),
+              selected = bothIds$targetIds[1],
+              multiple = F,
+              options = shinyWidgets::pickerOptions(
+                actionsBox = TRUE,
+                liveSearch = TRUE,
+                size = 10,
+                liveSearchStyle = "contains",
+                liveSearchPlaceholder = "Type here to search",
+                virtualScroll = 50
               )
-              ),
-
-            shiny::actionButton(
-              inputId = session$ns('generate'),
-              label = 'Generate Report'
             )
-          )
-        )
-      })
-
-
-      allData <- shiny::reactiveVal(NULL)
-      databaseNames <- shiny::reactiveVal(c('none'))
-      timespans <- shiny::reactiveVal(c('none'))
-
-      selectedInputs <- shiny::reactiveVal()
-      output$TTEinputsText <- shiny::renderUI(selectedInputs())
-
-
-      # fetch data when targetId changes
-      shiny::observeEvent(
-        eventExpr = input$generate,
-        {
-          if(is.null(input$targetId) | is.null(input$outcomeId)){
-            return(invisible(NULL))
-          }
+          ),
 
-          selectedInputs(
-            shinydashboard::box(
-              status = 'warning', 
-              width = "100%",
-              title = 'Selected:',
-              shiny::div(
-                shiny::fluidRow(
-                  shiny::column(
-                    width = 6,
-                    shiny::tags$b("Target:"),
-                    names(bothIds$targetIds)[bothIds$targetIds == input$targetId]
-                  ),
-                  shiny::column(
-                    width = 6,
-                    shiny::tags$b("Outcome:"),
-                    names(bothIds$outcomeIds[[1]])[bothIds$outcomeIds[[1]] == input$outcomeId]
-                  )
-                )
-
+          createInputSetting(
+            rowNumber = 1,                           
+            columnWidth = 6,
+            varName = 'outcomeId',
+            uiFunction = 'shinyWidgets::pickerInput',
+            uiInputs = list(
+              label = 'Outcome: ',
+              choices = bothIds$outcomeIds,
+              #choicesOpt = list(style = rep_len("color: black;", 999)),
+              selected = bothIds$outcomeIds[1],
+              multiple = F,
+              options = shinyWidgets::pickerOptions(
+                actionsBox = TRUE,
+                liveSearch = TRUE,
+                size = 10,
+                liveSearchStyle = "contains",
+                liveSearchPlaceholder = "Type here to search",
+                virtualScroll = 50
               )
             )
           )
-
-          tempData <- tryCatch({
-            getTimeToEventData(
-              targetId = input$targetId,
-              outcomeId = input$outcomeId,
-              connectionHandler = connectionHandler,
-              resultDatabaseSettings
-            )
-          }, 
-          error = function(e){shiny::showNotification(paste0('Error: ', e));return(NULL)}
-          )
-
-          if(is.null(tempData)){
-            shiny::showNotification('No data...')
-          } else{
-            shiny::showNotification(paste0('Data with ', nrow(tempData),' rows returned'))
-          }
-
-          allData(tempData)
-          databaseNames(unique(tempData$databaseName))  
-          timespans(unique(tempData$timeScale))  
-
-        }
+        )
       )
 
+      allData <- shiny::reactive({
+        getTimeToEventData(
+          targetId = inputSelected()$targetId,
+          outcomeId = inputSelected()$outcomeId,
+          connectionHandler = connectionHandler,
+          resultDatabaseSettings = resultDatabaseSettings
+        )
+      })
+
       output$timeToEventPlotInputs <- shiny::renderUI({
 
         shiny::fluidPage(
@@ -249,16 +170,16 @@ characterizationTimeToEventServer <- function(
             shiny::checkboxGroupInput(
               inputId = session$ns("databases"), 
               label = "Databases:",
-              choiceNames = databaseNames(), 
-              choiceValues = databaseNames(),
-              selected = databaseNames()
+              choiceNames = unique(allData()$databaseName), 
+              choiceValues = unique(allData()$databaseName),
+              selected = unique(allData()$databaseName)
             ),
             shiny::checkboxGroupInput(
               inputId = session$ns("times"), 
               label = "Timespan:",
-              choiceNames = timespans(), 
-              choiceValues = timespans(),
-              selected = timespans()
+              choiceNames = unique(allData()$timeScale), 
+              choiceValues = unique(allData()$timeScale),
+              selected = unique(allData()$timeScale)
             )
 
           )
@@ -268,7 +189,7 @@ characterizationTimeToEventServer <- function(
 
       output$timeToEvent <- shiny::renderPlot(
           plotTimeToEvent(
-            timeToEventData = allData,
+            timeToEventData = allData, # reactive
             databases = input$databases,
             times = input$times
           )
@@ -317,21 +238,12 @@ timeToEventGetIds <- function(
   targetIds <- targetUnique$targetCohortDefinitionId
   names(targetIds) <- targetUnique$target
 
-  outcomeIds <- lapply(targetIds, function(x){
-
-    outcomeUnique <- bothIds %>% 
-      dplyr::filter(.data$targetCohortDefinitionId == x) %>%
-      dplyr::select(c("outcomeCohortDefinitionId", "outcome")) %>%
-      dplyr::distinct()
-
-    outcomeIds <- outcomeUnique$outcomeCohortDefinitionId
-    names(outcomeIds) <- outcomeUnique$outcome
-
-    return(outcomeIds)
-
-    })
+  outcomeUnique <- bothIds %>% 
+    dplyr::select(c("outcomeCohortDefinitionId", "outcome")) %>%
+    dplyr::distinct()
 
-  names(outcomeIds) <- targetIds
+  outcomeIds <- outcomeUnique$outcomeCohortDefinitionId
+  names(outcomeIds) <- outcomeUnique$outcome
 
   shiny::incProgress(4/4, detail = paste("Finished"))
 
@@ -352,7 +264,9 @@ getTimeToEventData <- function(
   connectionHandler,
   resultDatabaseSettings
 ){
-
+  if(is.null(targetId)){
+    return(NULL)
+  }
 
   shiny::withProgress(message = 'Extracting time to event data', value = 0, {
 

diff --git a/R/cohort-method-diagnosticsSummary.R b/R/cohort-method-diagnosticsSummary.R
@@ -29,16 +29,6 @@ cohortMethodDiagnosticsSummaryViewer <- function(id) {
   ns <- shiny::NS(id)
 
   shiny::div(
-
-    #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',
@@ -52,7 +42,7 @@ cohortMethodDiagnosticsSummaryViewer <- function(id) {
           resultTableViewer(ns("diagnosticsTable"))
         )
       )
-    )
+    #)
   )
 }
 
@@ -179,6 +169,12 @@ cohortMethodDiagnosticsSummaryServer <- function(
             "The ..."
           )
         ),
+        sharedBalanceDiagnostic = reactable::colDef(
+          header = withTooltip(
+            "sharedBalanceDiagnostic",
+            "The ..."
+          )
+        ),
         easeDiagnostic = reactable::colDef(
           header = withTooltip(
             "easeDiagnostic",
@@ -349,7 +345,7 @@ getCmDiagnosticsData <- function(
       cmds.attrition_fraction,
       cmds.ease,
       cmds.balance_diagnostic,
-      --cmds.shared_balance_diagnostic,
+      cmds.shared_balance_diagnostic, -- added back
       cmds.equipoise_diagnostic,
       cmds.mdrr_diagnostic,
       cmds.attrition_diagnostic,