Merge branch 'OHDSI:main' into main

OHDSI · Nov 28, 2024 · c359f75 · c359f75
2 parents 007bbee + 1cb0577
commit c359f75
Show file tree

Hide file tree

Showing 21 changed files with 209 additions and 26 deletions.
diff --git a/.github/workflows/R_CMD_check_Hades.yaml b/.github/workflows/R_CMD_check_Hades.yaml
@@ -67,6 +67,7 @@ jobs:
         if: runner.os == 'Linux'
         run: |
           sudo apt-get install -y libssh-dev
+          Rscript -e 'install.packages("remotes")'
           while read -r cmd
           do
             eval sudo $cmd
@@ -93,13 +94,28 @@ jobs:
       - name: Install covr
         if: runner.os == 'Linux'
         run: |
-          install.packages("covr")
+          remotes::install_cran("covr")
+          remotes::install_cran("xml2")
         shell: Rscript {0}
 
       - name: Test coverage
         if: runner.os == 'Linux'
-        run: covr::codecov()
+        run: |
+          cov <- covr::package_coverage(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
+          )
+          covr::to_cobertura(cov)
         shell: Rscript {0}
+
+      - uses: codecov/codecov-action@v4
+        if: runner.os == 'Linux'
+        with:
+          file: ./cobertura.xml
+          plugin: noop
+          disable_search: true
+          token: ${{ secrets.CODECOV_TOKEN }}        
 
   Release:
     needs: R-CMD-Check

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: Strategus
 Type: Package
 Title: Coordinate and Execute OHDSI HADES Modules
-Version: 1.0.0
-Date: 2024-10-08
+Version: 1.1.0
+Date: 2024-11-26
 Authors@R: c(
 	person("Anthony", "Sena", email = "[email protected]", role = c("aut", "cre")),
 	person("Martijn", "Schuemie", email = "[email protected]", role = c("aut")),

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,9 @@
+Strategus 1.1.0
+===============
+- Inject cohort schema and table into `createCohortBasedCovariateSettings` (#181)
+- Provide hook to optimize cohort SQL construction (#179)
+- Fixes broken links in R6 class documentation (#183)
+
 Strategus 1.0.0
 ===============
 

diff --git a/R/Module-PatientLevelPrediction.R b/R/Module-PatientLevelPrediction.R
@@ -156,10 +156,9 @@ PatientLevelPredictionModule <- R6::R6Class(
     }
   ),
   private = list(
-    .setCovariateSchemaTable = function(
-        modelDesignList,
-        cohortDatabaseSchema,
-        cohortTable) {
+    .setCovariateSchemaTable = function(modelDesignList,
+                                        cohortDatabaseSchema,
+                                        cohortTable) {
       if (inherits(modelDesignList, "modelDesign")) {
         modelDesignList <- list(modelDesignList)
       }

diff --git a/R/Settings.R b/R/Settings.R
@@ -62,7 +62,7 @@ addModuleSpecifications <- function(analysisSpecifications, moduleSpecifications
 #' Add Characterization module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications   Created by the \href{../../docs/reference/CharacterizationModule.html#method-CharacterizationModule-createModuleSpecifications}{\code{CharacterizationModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications   Created by the \href{../reference/CharacterizationModule.html#method-CharacterizationModule-createModuleSpecifications}{\code{CharacterizationModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -81,7 +81,7 @@ addCharacterizationModuleSpecifications <- function(analysisSpecifications, modu
 #' Add Cohort Diagnostics module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/CohortDiagnosticsModule.html#method-CohortDiagnosticsModule-createModuleSpecifications}{\code{CohortDiagnosticsModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/CohortDiagnosticsModule.html#method-CohortDiagnosticsModule-createModuleSpecifications}{\code{CohortDiagnosticsModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -100,7 +100,7 @@ addCohortDiagnosticsModuleSpecifications <- function(analysisSpecifications, mod
 #' Add Cohort Generator module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/CohortGeneratorModule.html#method-CohortGeneratorModule-createModuleSpecifications}{\code{CohortGeneratorModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/CohortGeneratorModule.html#method-CohortGeneratorModule-createModuleSpecifications}{\code{CohortGeneratorModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -119,7 +119,7 @@ addCohortGeneratorModuleSpecifications <- function(analysisSpecifications, modul
 #' Add Cohort Incidence module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/CohortIncidenceModule.html#method-CohortIncidenceModule-createModuleSpecifications}{\code{CohortIncidenceModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/CohortIncidenceModule.html#method-CohortIncidenceModule-createModuleSpecifications}{\code{CohortIncidenceModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -138,7 +138,7 @@ addCohortIncidenceModuleSpecifications <- function(analysisSpecifications, modul
 #' Add Cohort Method module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/CohortMethodModule.html#method-CohortMethodModule-createModuleSpecifications}{\code{CohortMethodModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/CohortMethodModule.html#method-CohortMethodModule-createModuleSpecifications}{\code{CohortMethodModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -157,7 +157,7 @@ addCohortMethodeModuleSpecifications <- function(analysisSpecifications, moduleS
 #' Add Evidence Synthesis module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/EvidenceSynthesisModule.html#method-EvidenceSynthesisModule-createModuleSpecifications}{\code{EvidenceSynthesisModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/EvidenceSynthesisModule.html#method-EvidenceSynthesisModule-createModuleSpecifications}{\code{EvidenceSynthesisModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -176,7 +176,7 @@ addEvidenceSynthesisModuleSpecifications <- function(analysisSpecifications, mod
 #' Add Patient Level Prediction module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/PatientLevelPredictionModule.html#method-PatientLevelPredictionModule-createModuleSpecifications}{\code{PatientLevelPredictionModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/PatientLevelPredictionModule.html#method-PatientLevelPredictionModule-createModuleSpecifications}{\code{PatientLevelPredictionModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.
@@ -195,7 +195,7 @@ addPatientLevelPredictionModuleSpecifications <- function(analysisSpecifications
 #' Add Self Controlled Case Series Module module specifications to analysis specifications
 #'
 #' @template analysisSpecifications
-#' @param moduleSpecifications  Created by the \href{../../docs/reference/SelfControlledCaseSeriesModule.html#method-SelfControlledCaseSeriesModule-createModuleSpecifications}{\code{SelfControlledCaseSeriesModule$createModuleSpecifications()}} function.
+#' @param moduleSpecifications  Created by the \href{../reference/SelfControlledCaseSeriesModule.html#method-SelfControlledCaseSeriesModule-createModuleSpecifications}{\code{SelfControlledCaseSeriesModule$createModuleSpecifications()}} function.
 #'
 #' @return
 #' Returns the `analysisSpecifications` object with the module specifications added.

diff --git a/R/StrategusModule.R b/R/StrategusModule.R
@@ -159,14 +159,30 @@ StrategusModule <- R6::R6Class(
       }
       private$jobContext$settings <- moduleSpecification$settings
 
+      # Make sure that the covariate settings for the analysis are updated
+      # to reflect the location of the cohort tables if we are executing
+      # on a CDM.
+      if (inherits(executionSettings, "CdmExecutionSettings")) {
+        private$jobContext$settings <- .replaceCovariateSettings(
+          moduleSettings = private$jobContext$settings,
+          executionSettings = executionSettings
+        )
+      }
+
       # Assemble the job context from the analysis specification
       # for the given module.
       private$jobContext$sharedResources <- analysisSpecifications$sharedResources
       private$jobContext$moduleExecutionSettings <- executionSettings
       private$jobContext$moduleExecutionSettings$resultsSubFolder <- file.path(private$jobContext$moduleExecutionSettings$resultsFolder, self$moduleName)
+      if (!dir.exists(private$jobContext$moduleExecutionSettings$resultsSubFolder)) {
+        dir.create(private$jobContext$moduleExecutionSettings$resultsSubFolder, showWarnings = F, recursive = T)
+      }
 
       if (is(private$jobContext$moduleExecutionSettings, "ExecutionSettings")) {
         private$jobContext$moduleExecutionSettings$workSubFolder <- file.path(private$jobContext$moduleExecutionSettings$workFolder, self$moduleName)
+        if (!dir.exists(private$jobContext$moduleExecutionSettings$workSubFolder)) {
+          dir.create(private$jobContext$moduleExecutionSettings$workSubFolder, showWarnings = F, recursive = T)
+        }
       }
     },
     .getModuleSpecification = function(analysisSpecifications, moduleName) {
@@ -217,11 +233,21 @@ StrategusModule <- R6::R6Class(
       if (length(cohortDefinitions) <= 0) {
         stop("No cohort definitions found")
       }
+      # Provide hook to allow for custom SQL generation based on the Circe-be
+      # generated SQL
+      cohortSqlOptimizationFunction <- getOption("strategus.cohortSqlOptimizationFunction")
+      useCohortSqlOptimizationFunction <- is.function(cohortSqlOptimizationFunction)
+      if (isTRUE(useCohortSqlOptimizationFunction)) {
+        private$.message("Constructing cohort definition set and using strategus.cohortSqlOptimizationFunction")
+      }
       cohortDefinitionSet <- CohortGenerator::createEmptyCohortDefinitionSet()
       for (i in 1:length(cohortDefinitions)) {
         cohortJson <- cohortDefinitions[[i]]$cohortDefinition
         cohortExpression <- CirceR::cohortExpressionFromJson(cohortJson)
         cohortSql <- CirceR::buildCohortQuery(cohortExpression, options = CirceR::createGenerateOptions(generateStats = generateStats))
+        if (isTRUE(useCohortSqlOptimizationFunction)) {
+          cohortSql <- cohortSqlOptimizationFunction(cohortSql)
+        }
         cohortDefinitionSet <- rbind(cohortDefinitionSet, data.frame(
           cohortId = as.double(cohortDefinitions[[i]]$cohortId),
           cohortName = cohortDefinitions[[i]]$cohortName,
@@ -294,3 +320,62 @@ StrategusModule <- R6::R6Class(
     }
   )
 )
+
+# Utility function to set the cohort table & schema on
+# createCohortBasedCovariateSettings with information from
+# the execution settings (Issue #181)
+.replaceCovariateSettingsCohortTableNames <- function(covariateSettings, executionSettings) {
+  errorMessages <- checkmate::makeAssertCollection()
+  checkmate::assertList(covariateSettings, min.len = 1, add = errorMessages)
+  checkmate::assertClass(executionSettings, "CdmExecutionSettings", add = errorMessages)
+  checkmate::reportAssertions(collection = errorMessages)
+
+  .replaceProperties <- function(s) {
+    if (inherits(s, "covariateSettings") && "fun" %in% names(attributes(s))) {
+      if (attr(s, "fun") == "getDbCohortBasedCovariatesData") {
+        # Set the covariateCohortDatabaseSchema & covariateCohortTable values
+        s$covariateCohortDatabaseSchema <- executionSettings$workDatabaseSchema
+        s$covariateCohortTable <- executionSettings$cohortTableNames$cohortTable
+      }
+    }
+    return(s)
+  }
+  if (is.null(names(covariateSettings))) {
+    # List of lists
+    modifiedCovariateSettings <- lapply(covariateSettings, .replaceProperties)
+  } else {
+    # Plain list
+    modifiedCovariateSettings <- .replaceProperties(covariateSettings)
+  }
+  return(modifiedCovariateSettings)
+}
+
+.replaceCovariateSettings <- function(moduleSettings, executionSettings) {
+  errorMessages <- checkmate::makeAssertCollection()
+  checkmate::assertList(moduleSettings, min.len = 1, add = errorMessages)
+  checkmate::assertClass(executionSettings, "CdmExecutionSettings", add = errorMessages)
+  checkmate::reportAssertions(collection = errorMessages)
+
+  # A helper function to perform the replacement
+  replaceHelper <- function(x) {
+    if (is.list(x) && inherits(x, "covariateSettings")) {
+      # If the element is a list and of type covariate settings
+      # replace the cohort table names
+      return(.replaceCovariateSettingsCohortTableNames(x, executionSettings))
+    } else if (is.list(x)) {
+      # If the element is a list, recurse on each element
+      # Keep the original attributes by saving them before modification
+      attrs <- attributes(x)
+      newList <- lapply(x, replaceHelper)
+      # Restore attributes to the new list
+      attributes(newList) <- attrs
+      return(newList)
+    } else {
+      # If the element is not a list or "covariateSettings", return it as is
+      return(x)
+    }
+  }
+
+  # Call the helper function on the input list
+  return(replaceHelper(moduleSettings))
+}
diff --git a/extras/Strategus.pdf b/extras/Strategus.pdf
diff --git a/extras/rdms/schema_meta.xml b/extras/rdms/schema_meta.xml
@@ -1067,10 +1067,10 @@
     <table name="plp_model_designs" comments="PatientLevelPredictionModule: Model designs">
       <column name="model_design_id" comments="a unique identifier for the model design settings"/>
       <column name="target_id" comments="the  identifier for the target cohort id">
-        <foreignKey table="cg_cohort_definition" column="cohort_definition_id"/>
+        <foreignKey table="plp_cohorts" column="cohort_definition_id"/>
       </column>
       <column name="outcome_id" comments="the  identifier for the outcome cohort id">
-        <foreignKey table="cg_cohort_definition" column="cohort_definition_id"/>
+        <foreignKey table="plp_cohorts" column="cohort_definition_id"/>
       </column>
       <column name="tar_id" comments="the  identifier for the time at risk setting"/>
       <column name="plp_data_setting_id" comments="the  identifier for the plp data setting"/>

diff --git a/inst/doc/CreatingAnalysisSpecification.pdf b/inst/doc/CreatingAnalysisSpecification.pdf
diff --git a/inst/doc/ExecuteStrategus.pdf b/inst/doc/ExecuteStrategus.pdf
diff --git a/inst/doc/IntroductionToStrategus.pdf b/inst/doc/IntroductionToStrategus.pdf
diff --git a/inst/doc/WorkingWithResults.pdf b/inst/doc/WorkingWithResults.pdf
diff --git a/man/addCharacterizationModuleSpecifications.Rd b/man/addCharacterizationModuleSpecifications.Rd
diff --git a/man/addCohortDiagnosticsModuleSpecifications.Rd b/man/addCohortDiagnosticsModuleSpecifications.Rd
diff --git a/man/addCohortGeneratorModuleSpecifications.Rd b/man/addCohortGeneratorModuleSpecifications.Rd
diff --git a/man/addCohortIncidenceModuleSpecifications.Rd b/man/addCohortIncidenceModuleSpecifications.Rd
diff --git a/man/addCohortMethodeModuleSpecifications.Rd b/man/addCohortMethodeModuleSpecifications.Rd
diff --git a/man/addEvidenceSynthesisModuleSpecifications.Rd b/man/addEvidenceSynthesisModuleSpecifications.Rd