improving characterization

OHDSI · May 21, 2024 · a46afd0 · a46afd0
1 parent 9ac2d1a
commit a46afd0
Show file tree

Hide file tree

Showing 8 changed files with 653 additions and 245 deletions.
diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R
diff --git a/R/characterization-database.R b/R/characterization-database.R
@@ -54,7 +54,8 @@ characterizationDatabaseComparisonServer <- function(
     resultDatabaseSettings,
     options,
     parents,
-    parentIndex # reactive
+    parentIndex, # reactive
+    subTargetId # reactive
 ) {
   shiny::moduleServer(
     id,
@@ -73,27 +74,11 @@ characterizationDatabaseComparisonServer <- function(
       output$inputs <- shiny::renderUI({
 
         shiny::div(
-          shinyWidgets::pickerInput(
-            inputId = session$ns('targetId'), 
-            label = 'Target: ',
-            choices = children(),
-            selected = 1,
-            multiple = F,
-            options = shinyWidgets::pickerOptions(
-              actionsBox = TRUE,
-              liveSearch = TRUE,
-              size = 10,
-              liveSearchStyle = "contains",
-              liveSearchPlaceholder = "Type here to search",
-              virtualScroll = 50
-            )
-          ),
-
           shiny::selectInput(
             inputId = session$ns('databaseIds'), 
             label = 'Databases: ',
             choices = inputVals$databaseIds,
-            selected = 1,
+            selected = inputVals$databaseIds[1],
             multiple = T
           ),
 
@@ -127,19 +112,28 @@ characterizationDatabaseComparisonServer <- function(
       selected <- shiny::reactiveVal()
       shiny::observeEvent(input$generate,{
 
-        if(is.null(input$targetId)){
+        if(is.null(input$databaseIds)){
+          shiny::showNotification('No databases selected')
+          return(NULL)
+        }
+        if(length(input$databaseIds) == 0 ){
+          shiny::showNotification('No databases selected')
           return(NULL)
         }
 
+        selectedDatabases <- paste0(
+          names(inputVals$databaseIds)[which(inputVals$databaseIds %in% input$databaseIds)], 
+          collapse =  ','
+          )
+
         selected(
           data.frame(
-            Target = names(children())[which(input$targetId == children())],
+            Databases = selectedDatabases,
             minTreshold = input$minThreshold
           )
         )
 
-        selectedChildChar <- options[[parentIndex()]]$children[[which(input$targetId == children())]]$charIds
-
+        selectedChildChar <- options[[parentIndex()]]$children[[which(subTargetId() == children())]]$charIds
 
         #get results
         if(sum(selectedChildChar$databaseId %in% input$databaseIds) > 0){
@@ -178,8 +172,6 @@ characterizationDatabaseComparisonServer <- function(
           })
           names(sumColumns) <- unlist(lapply(1:nrow(databaseNames), function(i) paste0('sumValue_',databaseNames$id[i])))
 
-          print('HERE 3')
-
           columns <- append(
             list(
               covariateName = reactable::colDef(
@@ -200,8 +192,6 @@ characterizationDatabaseComparisonServer <- function(
             )
           )
 
-          print('HERE 4')
-
           resultTableServer(
             id = 'mainTable',
             df = result$table,

diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R
@@ -249,7 +249,7 @@ characterizationIncidenceServer <- function(
     parents,
     parentIndex, # reactive
     outcomes, # reactive
-    subTargets# reactive
+    targetIds # reactive
 ) {
   shiny::moduleServer(
     id,
@@ -289,16 +289,6 @@ characterizationIncidenceServer <- function(
              style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px;"
            ),
 
-           shiny::selectInput(
-             inputId = session$ns('targetIds'),
-             label = 'Target: ',
-             choices = subTargets(),
-             selected = 1,
-             multiple = T,
-             selectize = TRUE,
-             width = NULL,
-             size = NULL
-           ),
 
            shiny::selectInput(
              inputId = session$ns('outcomeIds'),
@@ -388,7 +378,6 @@ characterizationIncidenceServer <- function(
        })
 
      outcomeIds <- shiny::reactiveVal(NULL)
-     targetIds <- shiny::reactiveVal(NULL)
      incidenceRateTarFilter <- shiny::reactiveVal(NULL)
      incidenceRateCalendarFilter <- shiny::reactiveVal(NULL)
      incidenceRateAgeFilter <- shiny::reactiveVal(NULL)
@@ -399,7 +388,6 @@ characterizationIncidenceServer <- function(
        incidenceRateAgeFilter(input$ageIds)
        incidenceRateGenderFilter(input$sexIds)
        outcomeIds(input$outcomeIds)
-       targetIds(input$targetIds)
      })
 
 

diff --git a/R/characterization-main.R b/R/characterization-main.R
@@ -51,12 +51,18 @@ characterizationViewer <- function(id=1) {
     solidHeader = TRUE,
 
     # pick a targetId of interest 
-    shiny::uiOutput(ns("targetSelection")),
+    shinydashboard::box(
+      title = 'Target Of Interest', 
+      width = '100%',
+      status = "primary",
+      collapsible = T,
+      shiny::uiOutput(ns("targetSelection"))
+    ),
 
     shiny::conditionalPanel(
       condition = 'input.targetSelect', 
       ns = ns,
-      inputSelectionDfViewer(id = ns('targetSelected'), title = 'Selected'),
+      inputSelectionDfViewer(id = ns('targetSelected'), title = 'Selected Target'),
       shiny::tabsetPanel(
         type = 'pills',
         id = ns('mainPanel')
@@ -100,13 +106,32 @@ characterizationServer <- function(
       # PARENT TARGET SELECTION UI
       #================================================
       parents <- characterizationGetParents(options)
+      parentIndex <- shiny::reactiveVal(1)
+      subTargets <- shiny::reactiveVal()
+
       # add an input for all char that lets you select cohort of interest
       output$targetSelection <- shiny::renderUI({
         shiny::div(
-          shiny::selectInput(
+          shinyWidgets::pickerInput(
             inputId = session$ns('targetId'),
-            label = 'Parent Target: ',
+            label = 'Target Group: ',
             choices = parents,
+            selected = parents[1],
+            multiple = FALSE,
+            options = shinyWidgets::pickerOptions(
+              actionsBox = TRUE,
+              liveSearch = TRUE,
+              dropupAuto = F,
+              size = 10,
+              liveSearchStyle = "contains",
+              liveSearchPlaceholder = "Type here to search",
+              virtualScroll = 500
+            )
+          ),
+          shiny::selectInput(
+            inputId = session$ns('subTargetId'),
+            label = 'Target: ',
+            choices = characterizationGetChildren(options,1),
             selected = 1,
             multiple = FALSE,
             selectize = TRUE,
@@ -121,22 +146,35 @@ characterizationServer <- function(
         )
       })
 
-
+      #================================================
+      # UPDATE TARGET BASED ON TARGET GROUP
+      #================================================
+      shiny::observeEvent(input$targetId,{
+        parentIndex(which(parents == input$targetId))
+        subTargets(characterizationGetChildren(options,which(parents == input$targetId)))
+        shiny::updateSelectInput(
+          inputId = 'subTargetId',
+          label = 'Target: ',
+          choices = subTargets(), 
+          selected = subTargets()[1]
+          )
+      })
+
       #================================================
       # PARENT TARGET SELECTION ACTION
       #================================================
       # reactives updated when parent target is selected
-      parentIndex <- shiny::reactiveVal(1)
       outcomes <- shiny::reactiveVal()
-      subTargets <- shiny::reactiveVal()
       targetSelected <- shiny::reactiveVal()
+      subTargetId <- shiny::reactiveVal()
       # output the selected target
       shiny::observeEvent(input$targetSelect, {
 
         # First create input dataframe and add to the inputServer to display
         targetSelected(
           data.frame( 
-            `Parent Target` = names(parents)[parents == input$targetId]
+            `Target group` = names(parents)[parents == input$targetId],
+            `Target` = names(subTargets())[subTargets() == input$subTargetId]
           )
         )
         inputSelectionDfServer(
@@ -145,29 +183,17 @@ characterizationServer <- function(
           ncol = 1
         )
 
-        # update the parentIndex of interest
-        parentIndex(which(parents == input$targetId ))
+        subTargetId(input$subTargetId)
+
         # update the outcomes for the selected parent target id
         outcomes(characterizationGetOutcomes(options, parentIndex()))
-        # update the child targets for the selected parent target id
-        subTargets(characterizationGetChildren(options, parentIndex()))
-
+
         # create the outcome selector for the case exposure tabs
         output$outcomeSelection <- shiny::renderUI({
           shinydashboard::box(
             collapsible = TRUE,
             title = "Options",
             width = "100%",
-            shiny::selectInput(
-              inputId = session$ns('subTargetId'),
-              label = 'Target: ',
-              choices = subTargets(),
-              selected = 1,
-              multiple = FALSE,
-              selectize = TRUE,
-              width = NULL,
-              size = NULL
-            ),
             shiny::selectInput(
               inputId = session$ns('outcomeId'),
               label = 'Outcome: ',
@@ -195,19 +221,19 @@ characterizationServer <- function(
       # show the selected outcome
       outcomeSelected <- shiny::reactiveVal()
       outcomeId <- shiny::reactiveVal()
-      subTargetId <- shiny::reactiveVal()
+      #subTargetId <- shiny::reactiveVal()
 
       shiny::observeEvent(input$outcomeSelect, {
         outcomeSelected(
           data.frame( 
-            Target = names(subTargets())[subTargets() == input$subTargetId],
+            #Target = names(subTargets())[subTargets() == input$subTargetId],
             Outcome = names(outcomes())[outcomes() == input$outcomeId]
           )
         )
 
         # store the outcome and subTargetIds for the case exposure tabs
         outcomeId(input$outcomeId)
-        subTargetId(input$subTargetId)
+        #subTargetId(input$subTargetId)
 
         inputSelectionDfServer(
           id = 'outcomeSelected', 
@@ -376,7 +402,8 @@ characterizationServer <- function(
               resultDatabaseSettings = resultDatabaseSettings,
               options = options,
               parents = parents,
-              parentIndex = parentIndex
+              parentIndex = parentIndex,
+              subTargetId = subTargetId
             )
             previouslyLoaded(c(previouslyLoaded(), "Cohort Comparison"))
           }
@@ -393,7 +420,8 @@ characterizationServer <- function(
               resultDatabaseSettings = resultDatabaseSettings,
               options = options,
               parents = parents,
-              parentIndex = parentIndex
+              parentIndex = parentIndex,
+              subTargetId = subTargetId
             )
             previouslyLoaded(c(previouslyLoaded(), "Database Comparison"))
           }
@@ -477,7 +505,7 @@ characterizationServer <- function(
               parents = parents,
               parentIndex = parentIndex, # reactive
               outcomes = outcomes, # reactive
-              subTargets = subTargets# reactive
+              targetIds = subTargetId# reactive
             )
             previouslyLoaded(c(previouslyLoaded(), "Incidence Results"))
           }
@@ -571,7 +599,8 @@ characterizationGetOptions <- function(
 
   # get cohorts
   cg <- connectionHandler$queryDb(
-    sql = 'select * from @schema.@cg_table_prefixcohort_definition;',
+    sql = 'select * from @schema.@cg_table_prefixcohort_definition
+    ORDER BY cohort_name;',
     schema = resultDatabaseSettings$schema,
     cg_table_prefix = resultDatabaseSettings$cgTablePrefix
   )