stashed changes

OHDSI · Sep 12, 2023 · fd48ba8 · fd48ba8
1 parent 044d064
commit fd48ba8
Show file tree

Hide file tree

Showing 12 changed files with 126 additions and 271 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -18,6 +18,7 @@ export(characterizationTimeToEventServer)
 export(characterizationTimeToEventViewer)
 export(characterizationViewer)
 export(cohortCountsView)
+export(cohortDefinitionsModule)
 export(cohortDefinitionsView)
 export(cohortDiagCharacterizationView)
 export(cohortDiagnosticsHelperFile)
@@ -51,6 +52,7 @@ export(cohortMethodSystematicErrorViewer)
 export(cohortMethodViewer)
 export(cohortOverlapView)
 export(compareCohortCharacterizationView)
+export(conceptsInDataSourceUi)
 export(conceptsInDataSourceView)
 export(createCdDatabaseDataSource)
 export(createCustomColDefList)
@@ -107,6 +109,7 @@ export(sccsHelperFile)
 export(sccsServer)
 export(sccsView)
 export(timeDistributionsView)
+export(visitContextUi)
 export(visitContextView)
 importFrom(dplyr,"%>%")
 importFrom(rlang,.data)
diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R
@@ -20,8 +20,9 @@
 #'
 #' @param id    Namespace Id - use namespaced id ns("characterization") inside diagnosticsExplorer module
 #' @export
-cohortDiagCharacterizationView <- function(id) {
+cohortDiagCharacterizationView <- function(id, ...) {
   ns <- shiny::NS(id)
+
   shiny::tagList(
     shinydashboard::box(
       collapsible = TRUE,
@@ -497,17 +498,6 @@ cohortDiagCharacterizationModule <- function(
     selectedDatabaseIds <- shiny::reactive(input$targetDatabase)
     targetCohortId <- shiny::reactive(input$targetCohort)
 
-    getCohortConceptSets <- shiny::reactive({
-      if (!hasData(input$targetCohort) | nrow(dataSource$conceptSets) == 0) {
-        return(NULL)
-      }
-
-      dataSource$conceptSets %>%
-        dplyr::filter(.data$cohortId == input$targetCohort) %>%
-        dplyr::mutate(name = .data$conceptSetName, id = .data$conceptSetId) %>%
-        dplyr::select("id", "name")
-    })
-
     shiny::observe({
       # Default time windows
       selectedTimeWindows <- timeIdOptions %>%

diff --git a/R/cohort-diagnostics-compareCharacterization.R b/R/cohort-diagnostics-compareCharacterization.R
@@ -247,9 +247,9 @@ plotTemporalCompareStandardizedDifference <- function(balance,
 #' @param id    Namespace Id - use namespaced id ns("compareCohortCharacterization") inside diagnosticsExplorer module
 #' @param title     Optional string title field
 #' @export
-compareCohortCharacterizationView <- function(id, title = "Compare cohort characterization") {
+compareCohortCharacterizationView <- function(id, title = "Compare cohort characterization", ...) {
   ns <- shiny::NS(id)
-
+  print(id)
   shiny::tagList(
     shinydashboard::box(
       collapsible = TRUE,
@@ -811,7 +811,6 @@ compareCohortCharacterizationModule <- function(id,
                                                 domainIdOptions = dataSource$domainIdOptions,
                                                 temporalChoices = dataSource$temporalChoices) {
 
-
   shiny::moduleServer(id, function(input, output, session) {
     # Temporal choices (e.g. -30d - 0d ) are dynamic to execution
     timeIdOptions <- getResultsTemporalTimeRef(dataSource = dataSource) %>%
@@ -933,7 +932,6 @@ compareCohortCharacterizationModule <- function(id,
     shiny::observe({
       characterizationDomainOptionsUniverse <- NULL
       charcterizationDomainOptionsSelected <- NULL
-
       if (hasData(temporalAnalysisRef)) {
         characterizationDomainOptionsUniverse <- domainIdOptions
         charcterizationDomainOptionsSelected <-

diff --git a/R/cohort-diagnostics-definition.R b/R/cohort-diagnostics-definition.R
@@ -302,8 +302,9 @@ exportCohortDefinitionsZip <- function(cohortDefinitions,
 #' Outputs cohort definitions
 #' @param id            Namespace id for module
 #' @export
-cohortDefinitionsView <- function(id) {
+cohortDefinitionsView <- function(id, parentId = "DiagnosticsExplorer") {
   ns <- shiny::NS(id)
+
   ui <- shiny::tagList(
     shinydashboard::box(
       width = NULL,
@@ -514,27 +515,25 @@ getCountForConceptIdInCohort <-
 #' Cohort Definition module
 #' @description
 #' cohort defintion conceptsets, json etc
-#'
+#' @export
 #' @param id                            Namespace id
 #' @param dataSource                    DatabaseConnection
-#' @param cohortDefinitions             reactive of cohort definitions to display
 #' @param databaseTable                 data.frame of databasese, databaseId, name
 #' @param cohortTable                   data.frame of cohorts, cohortId, cohortName
 #' @param cohortCountTable              data.frame of cohortCounts, cohortId, subjects records
 cohortDefinitionsModule <- function(
     id,
     dataSource,
-    cohortDefinitions,
     cohortTable = dataSource$cohortTable,
     cohortCountTable = dataSource$cohortCountTable,
-    databaseTable = dataSource$dbTable
+    databaseTable = dataSource$dbTable,
+    ...
 ) {
-  ns <- shiny::NS(id)
 
   cohortDefinitionServer <- function(input, output, session) {
 
     cohortDefinitionTableData <- shiny::reactive(x = {
-      data <- cohortDefinitions() %>%
+      data <- cohortTable %>%
         dplyr::select("cohortId", "cohortName")
       return(data)
     })

diff --git a/R/cohort-diagnostics-incidenceRates.R b/R/cohort-diagnostics-incidenceRates.R
@@ -126,7 +126,7 @@ getIncidenceRateResult <- function(dataSource,
             {@age_group == TRUE} ? {AND ir.age_group != ''} : {  AND ir.age_group = ''}
             {@calendar_year == TRUE} ? {AND ir.calendar_year != ''} : {  AND ir.calendar_year = ''}
               AND ir.person_years > @personYears;"
-  
+
   data <-
     dataSource$connectionHandler$queryDb(
       sql = sql,
@@ -143,16 +143,16 @@ getIncidenceRateResult <- function(dataSource,
       snakeCaseToCamelCase = TRUE
     ) %>%
       tidyr::tibble()
-  
+
   # join with dbTable (moved this outside sql)
   data <- merge(
-    data, 
-    dataSource$dbTable, 
+    data,
+    dataSource$dbTable,
     by = 'databaseId'
-    )
-  
+  )
+
   data <- tidyr::as_tibble(data)
-  
+
   data <- data %>%
     dplyr::mutate(
       gender = dplyr::na_if(.data$gender, ""),
@@ -501,16 +501,18 @@ plotIncidenceRate <- function(data,
 #'
 #' @param id    Namespace Id - use namespaced id ns("incidenceRates") inside diagnosticsExplorer module
 #' @export
-incidenceRatesView <- function(id) {
+incidenceRatesView <- function(id, ...) {
   ns <- shiny::NS(id)
   shiny::tagList(
+
     shinydashboard::box(
       collapsible = TRUE,
       collapsed = TRUE,
       title = "Incidence Rates",
       width = "100%",
       shiny::htmlTemplate(system.file("cohort-diagnostics-www", "incidenceRate.html", package = utils::packageName()))
     ),
+     shinydashboard::box(cdUiControls(ns, inputPanel = "incidenceRates")),
     shinydashboard::box(
       width = NULL,
       status = "primary",
@@ -1042,7 +1044,7 @@ incidenceRatesModule <- function(id,
       )
     })
 
-  output$selectedCohorts <- shiny::renderUI({ selectionsOutput() })
+    output$selectedCohorts <- shiny::renderUI({ selectionsOutput() })
 
   })
 }
diff --git a/R/cohort-diagnostics-main-ui.R b/R/cohort-diagnostics-main-ui.R
@@ -14,12 +14,9 @@
 # See the License for the specific language governing permissions and
 # limitations under the License.
 
-cdUiControls <- function(ns) {
+cdUiControls <- function(ns, inputPanel) {
   panels <- shiny::tagList(
-    shiny::conditionalPanel(
-      condition = "
-      input.tabs == 'databaseInformation'",
-      ns = ns,
+    if (inputPanel == 'databaseInformation') {
       shinyWidgets::pickerInput(
         inputId = ns("database"),
         label = "Database",
@@ -35,18 +32,10 @@ cdUiControls <- function(ns) {
           virtualScroll = 50
         )
       )
-    ),
-    shiny::conditionalPanel(
-      condition = "input.tabs=='incidenceRates' |
-      input.tabs == 'timeDistribution' |
-      input.tabs == 'cohortCounts' |
-      input.tabs == 'indexEventBreakdown' |
-      input.tabs == 'conceptsInDataSource' |
-      input.tabs == 'orphanConcepts' |
-      input.tabs == 'inclusionRules' |
-      input.tabs == 'visitContext' |
-      input.tabs == 'cohortOverlap'",
-      ns = ns,
+    },
+
+    if (inputPanel %in% c("incidenceRates", 'timeDistribution', 'cohortCounts', 'indexEventBreakdown',
+                          'conceptsInDataSource', 'orphanConcepts', 'inclusionRules', 'visitContext', 'cohortOverlap')) {
       shinyWidgets::pickerInput(
         inputId = ns("databases"),
         label = "Database(s)",
@@ -62,14 +51,8 @@ cdUiControls <- function(ns) {
           virtualScroll = 50
         )
       )
-    ),
-    shiny::conditionalPanel(
-      condition = "
-      input.tabs == 'conceptsInDataSource' |
-      input.tabs == 'orphanConcepts'|
-      input.tabs == 'indexEvents' |
-      input.tabs == 'visitContext'",
-      ns = ns,
+    },
+    if (inputPanel %in% c('conceptsInDataSource', 'orphanConcepts', 'indexEvents', 'visitContext')) {
       shinyWidgets::pickerInput(
         inputId = ns("targetCohort"),
         label = "Cohort",
@@ -85,13 +68,8 @@ cdUiControls <- function(ns) {
           virtualScroll = 50
         )
       )
-    ),
-    shiny::conditionalPanel(
-      condition = "input.tabs == 'cohortCounts' |
-      input.tabs == 'cohortOverlap' |
-      input.tabs == 'incidenceRates' |
-      input.tabs == 'timeDistributions'",
-      ns = ns,
+    },
+    if (inputPanel %in% c('cohortCounts', 'cohortOverlap', 'incidenceRates', 'timeDistributions')) {
       shinyWidgets::pickerInput(
         inputId = ns("cohorts"),
         label = "Cohorts",
@@ -109,12 +87,8 @@ cdUiControls <- function(ns) {
           virtualScroll = 50
         )
       )
-    ),
-    shiny::conditionalPanel(
-      condition = "input.tabs == 'temporalCharacterization' |
-      input.tabs == 'conceptsInDataSource' |
-      input.tabs == 'orphanConcepts'",
-      ns = ns,
+    },
+    if (inputPanel %in% c('temporalCharacterization', 'conceptsInDataSource', 'orphanConcepts')) {
       shinyWidgets::pickerInput(
         inputId = ns("conceptSetsSelected"),
         label = "Concept sets",
@@ -131,7 +105,7 @@ cdUiControls <- function(ns) {
           virtualScroll = 50
         )
       )
-    )
+    }
   )
 
   return(panels)
@@ -170,12 +144,6 @@ cohortDiagnosticsView <- function(id = "DiagnosticsExplorer") {
       title = "Cohort Level Diagnostics",
       width = "100%",
       shiny::fluidRow(
-        shiny::column(
-          shiny::selectInput(inputId = ns("tabs"),
-                             label = "Select Report",
-                             choices = c(), selected = NULL),
-          width = 12
-        ),
         shiny::column(
           cdUiControls(ns),
           width = 12
@@ -250,4 +218,49 @@ cohortDiagnosticsView <- function(id = "DiagnosticsExplorer") {
       )
     )
   )
+}
+
+#' The user interface to the cohort diagnostics viewer module
+#' @param id id
+#' @param parentId parent namespace
+#' @export
+conceptsInDataSourceUi <- function(id, parentId = "DiagnosticsExplorer") {
+  ns <- shiny::NS(id)
+
+  ui <- shiny::fluidPage(
+    shiny::fluidRow(
+      shinydashboard::box(
+        cdUiControls(ns, inputPanel = "conceptsInDataSource"),
+        width = 12
+      )
+    ),
+    shiny::fluidRow(
+      conceptsInDataSourceView(id)
+    )
+  )
+
+  return(ui)
+}
+
+#' The user interface to the cohort diagnostics viewer module
+#' @param id id
+#' @param parentId parent namespace
+#' @export
+visitContextUi <- function(id, parentId = "DiagnosticsExplorer") {
+  ns <- shiny::NS(id)
+  parentNs <- shiny::NS(parentId)
+
+  ui <- shiny::fluidPage(
+    shiny::fluidRow(
+      shinydashboard::box(
+        cdUiControls(parentNs, inputPanel = "visitContext"),
+        width = 12
+      )
+    ),
+    shiny::fluidRow(
+      visitContextView(id)
+    )
+  )
+
+  return(ui)
 }