add params to getDBCovariateData

R/GetCovariates.R

@@ -69,6 +69,8 @@
 #' @param tempEmulationSchema    Some database platforms like Oracle and Impala do not truly support
 #'                               temp tables. To emulate temp tables, provide a schema with write
 #'                               privileges where temp tables can be created.
+#' @param covariateCohortDatabaseSchema The database schema where the cohorts used to define the covariates can be found.
+#' @param covariateCohortTable          The table where the cohorts used to define the covariates can be found. 
 #'
 #' @return
 #' Returns an object of type \code{covariateData}, containing information on the covariates.
@@ -113,7 +115,9 @@ getDbCovariateData <- function(connectionDetails = NULL,
                                covariateSettings,
                                aggregated = FALSE,
                                minCharacterizationMean = 0,
-                               tempEmulationSchema = getOption("sqlRenderTempEmulationSchema")) {
+                               tempEmulationSchema = getOption("sqlRenderTempEmulationSchema"),
+                               covariateCohortDatabaseSchema = NULL,
+                               covariateCohortTable = NULL) {
   if (is.null(connectionDetails) && is.null(connection)) {
     stop("Need to provide either connectionDetails or connection")
   }
@@ -181,6 +185,11 @@ getDbCovariateData <- function(connectionDetails = NULL,
       hasData <- function(data) {
         return(!is.null(data) && (data %>% count() %>% pull()) > 0)
       }
+      if (!is.null(covariateCohortDatabaseSchema) && !is.null(covariateCohortTable)) {
+        covariateSettings <- replaceCovariateSettingsCohortSchemaTable(covariateSettings,
+                                                                       covariateCohortDatabaseSchema,
+                                                                       covariateCohortTable)
+      }
       for (i in 1:length(covariateSettings)) {
         fun <- attr(covariateSettings[[i]], "fun")
         args <- list(

R/GetCovariatesFromOtherCohorts.R

@@ -325,3 +325,42 @@ warnIfPredefined <- function(analysisId, temporal = FALSE) {
     warning(sprintf("Analysis ID %d also used for prespecified analysis '%s'.", analysisId, preSpecAnalysis$analysisName))
   }
 }
+
+#' Utility function to set the cohort table & schema on createCohortBasedCovariateSettings 
+#' with information from the execution settings
+#' 
+#' @param covariateSettings An object of type \code{covariateSettings}
+#' @param covariateCohortDatabaseSchema The database schema where the cohorts used to define the covariates can be found.
+#' @param covariateCohortTable The table where the cohorts used to define the covariates can be found.
+#'
+#' @return
+#' An object of type \code{covariateSettings}
+#'
+replaceCovariateSettingsCohortSchemaTable <- function(covariateSettings, 
+                                                      covariateCohortDatabaseSchema,
+                                                      covariateCohortTable) {
+  errorMessages <- checkmate::makeAssertCollection()
+  checkmate::assertList(covariateSettings, min.len = 1, add = errorMessages)
+  checkmate::assertCharacter(covariateCohortDatabaseSchema, add = errorMessages)
+  checkmate::assertCharacter(covariateCohortTable, 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 <- covariateCohortDatabaseSchema
+        s$covariateCohortTable <- covariateCohortTable
+      }
+    }
+    return(s)
+  }
+  if (is.null(names(covariateSettings))) {
+    # List of lists
+    modifiedCovariateSettings <- lapply(covariateSettings, replaceProperties)
+  } else {
+    # Plain list
+    modifiedCovariateSettings <- replaceProperties(covariateSettings)
+  }
+  return(modifiedCovariateSettings)
+}

tests/testthat/test-GetCohortBasedCovariates.R

@@ -70,7 +70,8 @@ dropCohortBasedCovariateTestData <- function(connection,
 }
 
 # Database specific tests ---------------
-runCohortBasedBinaryNonAggTest <- function(connection, cdmDatabaseSchema, ohdsiDatabaseSchema, cohortTable) {
+runCohortBasedBinaryNonAggTest <- function(connection, cdmDatabaseSchema, ohdsiDatabaseSchema, cohortTable, 
+                                           covariateCohortDatabaseSchema = NULL, covariateCohortTable = NULL) {
   createCohortBasedCovariateTestData(
     connection = connection,
     databaseSchema = ohdsiDatabaseSchema,
@@ -99,7 +100,9 @@ runCohortBasedBinaryNonAggTest <- function(connection, cdmDatabaseSchema, ohdsiD
     cdmVersion = "5",
     rowIdField = "subject_id",
     covariateSettings = settings,
-    aggregated = FALSE
+    aggregated = FALSE,
+    covariateCohortDatabaseSchema = covariateCohortDatabaseSchema,
+    covariateCohortTable = covariateCohortTable
   )
 
   covariates <- dplyr::collect(covs$covariates)
@@ -485,6 +488,28 @@ test_that("Cohort-based covariates: binary, non-aggregated on Eunomia", {
   )
 })
 
+test_that("Cohort-based covariates: binary, non-aggregated, custom covariate cohort schema/table on Eunomia", {
+  skip_if_not(dbms == "sqlite" && exists("eunomiaConnection"))
+  runCohortBasedBinaryNonAggTest(
+    connection = eunomiaConnection,
+    cdmDatabaseSchema = eunomiaCdmDatabaseSchema,
+    ohdsiDatabaseSchema = eunomiaOhdsiDatabaseSchema,
+    cohortTable = "cohort_cov",
+    covariateCohortDatabaseSchema = eunomiaOhdsiDatabaseSchema, 
+    covariateCohortTable = "cohort_cov"
+  )
+  testthat::expect_error( 
+    runCohortBasedBinaryNonAggTest(
+      connection = eunomiaConnection,
+      cdmDatabaseSchema = eunomiaCdmDatabaseSchema,
+      ohdsiDatabaseSchema = eunomiaOhdsiDatabaseSchema,
+      cohortTable = "cohort_cov",
+      covariateCohortDatabaseSchema = "unknown", 
+      covariateCohortTable = "unknown"
+    ),
+    "no such table: unknown.unknown")
+})
+
 test_that("Cohort-based covariates: binary, aggregated on Eunomia", {
   skip_on_cran()
   skip_if_not(dbms == "sqlite" && exists("eunomiaConnection"))