Merge pull request #346 from OHDSI/develop

Develop

.github/workflows/R_CMD_check_Hades.yaml

@@ -22,6 +22,7 @@ jobs:
         config:
           - {os: windows-latest, r: 'release'}
           - {os: macOS-latest, r: 'release'}
+          - {os: ubuntu-22.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/jammy/latest"}
 
     env:
       GITHUB_PAT: ${{ secrets.GH_TOKEN }}
@@ -50,9 +51,10 @@ jobs:
       CDM5_SPARK_USER: ${{ secrets.CDM5_SPARK_USER }}
       CDM5_SPARK_PASSWORD: ${{ secrets.CDM5_SPARK_PASSWORD }}
       CDM5_SPARK_CONNECTION_STRING: ${{ secrets.CDM5_SPARK_CONNECTION_STRING }}
+      _JAVA_OPTIONS: -Xss3m
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2
         with:
@@ -85,7 +87,7 @@ jobs:
 
       - name: Upload source package
         if: success() && runner.os == 'macOS' && github.event_name != 'pull_request' && github.ref == 'refs/heads/main'
-        uses: actions/upload-artifact@v2
+        uses: actions/upload-artifact@v4
         with:
           name: package_tarball
           path: check/*.tar.gz
@@ -113,7 +115,7 @@ jobs:
 
     steps:
 
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
         with:
           fetch-depth: 0
 
@@ -155,7 +157,7 @@ jobs:
 
       - name: Download package tarball
         if: ${{ env.new_version != '' }}
-        uses: actions/download-artifact@v2
+        uses: actions/download-artifact@v4
         with:
           name: package_tarball
 

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: OhdsiShinyModules
 Type: Package
 Title: Repository of Shiny Modules for OHDSI Result Viewers
-Version: 3.0.0
+Version: 3.0.1
 Authors@R: c(
   person("Jenna", "Reps", email = "[email protected]", role = c("aut", "cre")),
   person("Nathan", "Hall", role = c("aut")),
@@ -62,4 +62,4 @@ Suggests:
 Remotes:
     ohdsi/ReportGenerator,
     ohdsi/ResultModelManager
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NEWS.md

@@ -1,3 +1,12 @@
+OhdsiShinyModules v3.0.1
+========================
+- Bug fixes
+
+OhdsiShinyModules v3.0.0
+========================
+- Removed CohortMethod/SCCS/EvidenceSyntheis modules as these
+are replaced with Estimation 
+
 OhdsiShinyModules v2.2.1
 ========================
 - Fixed issue in DatabaseConnector check for pooled connections of sqlite databases on cohort diagnotiscs load (from main hotfix)

R/characterization-caseSeries.R

@@ -74,20 +74,38 @@ characterizationCaseSeriesServer <- function(
       output$inputs <- shiny::renderUI({ # need to make reactive?
 
         shiny::div(
-          shiny::selectInput(
+          shinyWidgets::pickerInput(
             inputId = session$ns('databaseId'),
             label = 'Database: ',
             choices = options()$databaseIds,
             selected = options()$databaseIds[1],
-            multiple = F
+            multiple = F,
+            options = shinyWidgets::pickerOptions(
+              actionsBox = TRUE,
+              liveSearch = TRUE,
+              size = 10,
+              dropupAuto = TRUE,
+              liveSearchStyle = "contains",
+              liveSearchPlaceholder = "Type here to search",
+              virtualScroll = 50
+            )
           ),
 
-          shiny::selectInput(
+          shinyWidgets::pickerInput(
             inputId = session$ns('tarInd'),
             label = 'Time-at-risk: ',
             choices = options()$tarInds,
             selected = options()$tarInds[1],
-            multiple = F
+            multiple = F,
+            options = shinyWidgets::pickerOptions(
+              actionsBox = TRUE,
+              liveSearch = TRUE,
+              size = 10,
+              dropupAuto = TRUE,
+              liveSearchStyle = "contains",
+              liveSearchPlaceholder = "Type here to search",
+              virtualScroll = 50
+            )
           ),
 
           shiny::actionButton(

R/characterization-cohorts.R

@@ -969,6 +969,9 @@ characterizatonGetCohortComparisonDataContinuous <- function(
                                    -"settingId", -"targetCohortId", -"outcomeCohortId", 
                                    -"cohortType") %>%
         dplyr::relocate("databaseName", .after = "covariateName")
+
+      # fill missing values with 0
+      res[is.na(res)] <- 0
     }
 
     shiny::incProgress(4/4, detail = paste("Done"))

R/characterization-database.R

@@ -85,12 +85,21 @@ characterizationDatabaseComparisonServer <- function(
       output$inputs <- shiny::renderUI({
 
         shiny::div(
-          shiny::selectInput(
+          shinyWidgets::pickerInput(
             inputId = session$ns('databaseIds'), 
             label = 'Databases: ',
             choices = inputVals()$databaseIds,
             selected = inputVals()$databaseIds[1],
-            multiple = T
+            multiple = T,
+            options = shinyWidgets::pickerOptions(
+              actionsBox = TRUE,
+              liveSearch = TRUE,
+              size = 10,
+              dropupAuto = TRUE,
+              liveSearchStyle = "contains",
+              liveSearchPlaceholder = "Type here to search",
+              virtualScroll = 50
+            )
           ),
 
           shiny::sliderInput(

R/characterization-incidence.R

@@ -268,21 +268,27 @@ characterizationIncidenceServer <- function(
             style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px;"
           ),
 
-          shiny::selectInput(
+          shinyWidgets::pickerInput(
             inputId = session$ns('outcomeIds'),
             label = 'Outcome: ',
             choices = outcomes(),
-            selected = 1,
+            selected = outcomes()[1],
             multiple = T,
-            selectize = TRUE,
-            width = NULL,
-            size = NULL
+            options = shinyWidgets::pickerOptions(
+              actionsBox = TRUE,
+              liveSearch = TRUE,
+              size = 10,
+              dropupAuto = TRUE,
+              liveSearchStyle = "contains",
+              liveSearchPlaceholder = "Type here to search",
+              virtualScroll = 50
+            )
           ),
 
           shinyWidgets::pickerInput(
             inputId = session$ns('databaseSelector'),
             label = 'Filter By Database: ',
-            choices = ciOptions$databases,
+            choices = sort(ciOptions$databases),
             selected = ciOptions$databases,
             multiple = T,
             options = shinyWidgets::pickerOptions(
@@ -1691,9 +1697,6 @@ getIncidenceData <- function(
 ){
   if(!is.null(targetIds) & !is.null(outcomeIds)){
 
-    print(targetIds)
-    print(outcomeIds)
-
     shiny::withProgress(message = 'Getting incidence data', value = 0, {
 
     sql <- 'select d.cdm_source_abbreviation, i.*, ct1.cohort_name as target_name, ct2.cohort_name as outcome_name

R/characterization-riskFactors.R

@@ -684,8 +684,41 @@ characteriationCountsColDefs <- function(
       filterable = T
     ),
 
+    minPriorObservation = reactable::colDef(
+      header = withTooltip("Min Prior Observation",
+                           "Minimum prior observation time (days)"),
+      filterable = T,
+      filterInput = function(values, name) {
+        shiny::tags$select(
+          # Set to undefined to clear the filter
+          onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name),
+          # "All" has an empty value to clear the filter, and is the default option
+          shiny::tags$option(value = "", "All"),
+          lapply(unique(values), shiny::tags$option),
+          "aria-label" = sprintf("Filter %s", name),
+          style = "width: 100%; height: 28px;"
+        )
+      }
+    ), 
+    outcomeWashoutDays = reactable::colDef(
+      header = withTooltip("Outcome Washout Days",
+                           "Number of days for the outcome washout"),
+      filterable = T,
+      filterInput = function(values, name) {
+        shiny::tags$select(
+          # Set to undefined to clear the filter
+          onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name),
+          # "All" has an empty value to clear the filter, and is the default option
+          shiny::tags$option(value = "", "All"),
+          lapply(unique(values), shiny::tags$option),
+          "aria-label" = sprintf("Filter %s", name),
+          style = "width: 100%; height: 28px;"
+        )
+      }
+    ),
+
     rowCount = reactable::colDef(
-      header = withTooltip("# rows",
+      header = withTooltip("# Rows",
                            "Number of exposures in the cohort (people can be in more than once)"),
       cell = function(value) {
         if(is.null(value)){return('< min threshold')}
@@ -694,7 +727,7 @@ characteriationCountsColDefs <- function(
       }
     ), 
     personCount = reactable::colDef(
-      header = withTooltip("# persons",
+      header = withTooltip("# Persons",
                            "Number of distinct people in the cohort"),
       cell = function(value) {
         if(is.null(value)){return('< min threshold')}

R/characterization-timeToEvent.R

@@ -174,12 +174,21 @@ characterizationTimeToEventServer <- function(
         shiny::fluidPage(
           shiny::fluidRow(
 
-            shiny::selectInput(
+            shinyWidgets::pickerInput(
               inputId = session$ns("databases"),
               label = "Databases:",
               multiple = T, 
               choices = unique(allData()$databaseName),
-              selected = unique(allData()$databaseName)
+              selected = unique(allData()$databaseName),
+              options = shinyWidgets::pickerOptions(
+                actionsBox = TRUE,
+                liveSearch = TRUE,
+                size = 10,
+                dropupAuto = TRUE,
+                liveSearchStyle = "contains",
+                liveSearchPlaceholder = "Type here to search",
+                virtualScroll = 50
+                )
               ),
 
             shiny::fluidRow(

R/cohort-diagnostics-characterization.R

@@ -862,6 +862,8 @@ cohortDiagCharacterizationModule <- function(
       params$time_id <- ""
       params$use_database_id <- TRUE
       params$database_table <- dataSource$databaseTable
+      params$database_table_prefix <- dataSource$databaseTablePrefix
+      params$database_name <- ifelse(tolower(dataSource$databaseTable) == 'database_meta_data', 'cdm_source_name', 'database_name')
       return(params)
     })
 
@@ -1054,11 +1056,11 @@ cohortDiagCharacterizationModule <- function(
           FROM @results_database_schema.@table_prefixtemporal_covariate_ref tcr
           INNER JOIN @results_database_schema.@table_prefixtemporal_analysis_ref tar ON tar.analysis_id = tcr.analysis_id
           INNER JOIN @results_database_schema.@table_prefixtemporal_covariate_value tcv ON tcr.covariate_id = tcv.covariate_id
-          INNER JOIN @results_database_schema.@database_table db ON db.database_id = tcv.database_id
+          INNER JOIN @results_database_schema.@database_table_prefix@database_table db ON db.database_id = tcv.database_id
           WHERE tcr.covariate_id IS NOT NULL
         "
 
-        selectSt <- "db.database_name,
+        selectSt <- "db.@database_name as database_name,
             tcr.covariate_name,
             tar.analysis_name,
             is_binary,
@@ -1076,13 +1078,21 @@ cohortDiagCharacterizationModule <- function(
         # Select casees for each db
         for (i in 1:length(timeIds)) {
           timeId <- timeIds[i]
-          tplSql <- c(tplSql, SqlRender::render(selectTemplate, i = i, time_id = timeId))
-          havingSql <- c(havingSql, SqlRender::render(havingTemplate, time_id = timeId))
+          tplSql <- c(tplSql, SqlRender::render(
+            sql = selectTemplate, 
+            i = i, 
+            time_id = timeId)
+            )
+          havingSql <- c(havingSql, SqlRender::render(
+            sql = havingTemplate, 
+            time_id = timeId
+            )
+            )
         }
 
         tplSql <- paste(tplSql, collapse = ", \n")
         groupClause <- SqlRender::render("
-        GROUP BY db.database_name, tcr.covariate_name, tar.analysis_name, tcr.concept_id, is_binary
+        GROUP BY db.@database_name, tcr.covariate_name, tar.analysis_name, tcr.concept_id, is_binary
         HAVING @having_clasuse
         ", having_clasuse = paste(havingSql, collapse = " OR\n"))
 

R/cohort-diagnostics-cohort-overlap.R

@@ -128,7 +128,10 @@ plotCohortOverlap <- function(data,
                                     title = "",
                                     gridcolor = 'ffff'),
                        yaxis = list(zerolinecolor = '#ffff',
-                                    title = database,
+                                    title = addTextBreaks(
+                                      text = database, 
+                                      length = 25
+                                      ),
                                     zerolinewidth = 1,
                                     gridcolor = 'ffff'))
 

R/cohort-diagnostics-databaseInformation.R

@@ -29,7 +29,7 @@ databaseInformationView <- function(id) {
     shinydashboard::box(
       width = NULL,
       title = "Execution meta-data",
-      shiny::tags$p("Each entry relates to execution on a given cdm. Results are merged between executions incrementally"),
+      shiny::tags$p("Each entry relates to execution on a given CDM. Results are merged between executions incrementally"),
       shinycssloaders::withSpinner(reactable::reactableOutput(outputId = ns("databaseInformationTable"))),
       shiny::conditionalPanel(
         "output.databaseInformationTableIsSelected == true",
@@ -212,7 +212,7 @@ getExecutionMetadata <- function(dataSource, databaseId) {
 
 
 getDatabaseMetadata <- function(dataSource, databaseTable) {
-  data <- loadResultsTable(dataSource, "metadata", required = TRUE, cdTablePrefix = dataSource$cdTablePrefix)
+  data <- loadResultsTable(dataSource, "metadata", required = TRUE, cdTablePrefix = dataSource$cdTablePrefix, databaseTablePrefix = dataSource$databaseTablePrefix)
   data <- data %>%
     tidyr::pivot_wider(
       id_cols = c("startTime", "databaseId"),