Merge branch 'develop' into issue294

.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,6 +51,7 @@ 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@v4

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.2
 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,16 @@
+OhdsiShinyModules v3.0.2
+========================
+- Fixed bug with orphan concepts not loading
+
+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/OhdsiShinyModules.R

@@ -24,4 +24,4 @@
 #' @keywords internal
 #' @importFrom dplyr %>%
 #' @importFrom rlang .data
-"_PACKAGE"
+"_PACKAGE"

R/characterization-cohorts.R

@@ -1055,6 +1055,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-incidence.R

@@ -1697,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
@@ -1901,4 +1898,4 @@ characterizationGetCiTars <- function(connectionHandler,
       niceColNames = colDefCsv$niceName,
       tooltipText = colDefCsv$toolTip
     )
-}
+}

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-databaseInformation.R

@@ -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"),

R/cohort-diagnostics-main.R

@@ -35,8 +35,8 @@
 
 # NOTE: here it would be nice to use dbplyr tables - this would allow lazy loading of resources
 # however, renaming the columns causes an error and its not obvious how it could be resolved
-loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePrefix = "") {
-  selectTableName <- paste0(cdTablePrefix, tableName)
+loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePrefix = "", databaseTablePrefix = "") {
+  selectTableName <- paste0(ifelse(!tolower(tableName) == 'database_meta_data', cdTablePrefix,databaseTablePrefix), tableName)
   resultsTablesOnServer <-
     tolower(.availableTables(dataSource$connectionHandler, dataSource$schema))
 
@@ -47,9 +47,20 @@ loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePre
 
     tryCatch(
       {
-        table <- dataSource$connectionHandler$queryDb("SELECT * FROM @schema.@table",
-                                                      schema = dataSource$schema,
-                                                      table = selectTableName)
+
+        if(tolower(tableName) == 'database_meta_data'){
+          table <- dataSource$connectionHandler$queryDb(
+            "SELECT *, cdm_source_name as database_name FROM @schema.@table",
+            schema = dataSource$schema,
+            table = selectTableName
+          )
+        } else{
+          table <- dataSource$connectionHandler$queryDb(
+            "SELECT * FROM @schema.@table",
+            schema = dataSource$schema,
+            table = selectTableName
+          )
+        }
       },
       error = function(err) {
         stop(
@@ -224,7 +235,13 @@ createCdDatabaseDataSource <- function(
     dbms = connectionHandler$dbms(),
     resultsTablesOnServer = .availableTables(connectionHandler, resultDatabaseSettings$schema),
     cdTablePrefix = resultDatabaseSettings$cdTablePrefix,
-    prefixTable = function(tableName) { paste0(resultDatabaseSettings$cdTablePrefix, tableName) },
+    prefixTable = function(tableName) {
+      if(tableName != resultDatabaseSettings$databaseTable){
+        return(paste0(resultDatabaseSettings$cdTablePrefix, tableName))
+      } else{
+        return(paste0(resultDatabaseSettings$databaseTablePrefix, tableName))
+      }
+      },
     prefixVocabTable = function(tableName) {
       # don't prexfix table if we us a dedicated vocabulary schema
       if (resultDatabaseSettings$vocabularyDatabaseSchema == resultDatabaseSettings$schema)
@@ -235,8 +252,8 @@ createCdDatabaseDataSource <- function(
     cgTable = resultDatabaseSettings$cgTable,
     cgTablePrefix = resultDatabaseSettings$cgTablePrefix,
     useCgTable = FALSE,
-    databaseTable = "database",
-    databaseTablePrefix = "cd_",
+    databaseTable = resultDatabaseSettings$databaseTable,#"database",
+    databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix,#"cd_",
     dataModelSpecifications = modelSpec
   )
 
@@ -317,6 +334,7 @@ createCdDatabaseDataSource <- function(
 
 getDatabaseTable <- function(dataSource) {
   databaseTable <- loadResultsTable(dataSource, dataSource$prefixTable(dataSource$databaseTable), required = TRUE)
+
   if (nrow(databaseTable) > 0 &
       "vocabularyVersion" %in% colnames(databaseTable)) {
     databaseTable <- databaseTable %>%
@@ -475,7 +493,7 @@ cohortDiagnosticsServer <- function(id,
       if ("includedSourceConcept" %in% dataSource$enabledReports)
         selection["Concepts In Data Source"] <- "conceptsInDataSource"
 
-      if ("orphanConcepts" %in% dataSource$enabledReports)
+      if ("orphanConcept" %in% dataSource$enabledReports)
         selection["Orphan Concepts"] <- "orphanConcepts"
 
       if ("indexEventBreakdown" %in% dataSource$enabledReports)
@@ -603,6 +621,9 @@ cohortDiagnosticsServer <- function(id,
       if (!hasData(targetCohortId())) {
         return(NULL)
       }
+      if (sum(c('cohortId','conceptSetName') %in% colnames(dataSource$conceptSets)) !=2) {
+        return(NULL)
+      }
       dataSource$conceptSets %>%
         dplyr::filter(.data$cohortId == targetCohortId()) %>%
         dplyr::mutate(name = .data$conceptSetName) %>%
@@ -744,4 +765,4 @@ cohortDiagnosticsServer <- function(id,
 
   )
 
-}
+}