issue #328

R/documentationHelper.R

@@ -136,3 +136,11 @@ NULL
 #' @keywords internal
 NULL
 
+#' Helper for consistent documentation of `keepOriginalCohorts`.
+#'
+#' @param keepOriginalCohorts If TRUE the original cohorts will be return
+#' together with the new ones. If FALSE only the new cohort will be returned.
+#'
+#' @name keepOriginalCohortsDoc
+#' @keywords internal
+NULL

R/intersectCohorts.R

@@ -10,11 +10,9 @@
 #' @inheritParams cohortIdSubsetDoc
 #' @inheritParams gapDoc
 #' @inheritParams nameDoc
+#' @inheritParams keepOriginalCohortsDoc
 #' @param returnNonOverlappingCohorts Whether the generated cohorts are mutually
 #' exclusive or not.
-#' @param keepOriginalCohorts If TRUE the original cohorts and the newly
-#' created intersection cohort will be returned. If FALSE only the new cohort
-#' will be returned.
 #'
 #' @export
 #'

R/matchCohorts.R

@@ -7,6 +7,7 @@
 #' @inheritParams cohortDoc
 #' @inheritParams cohortIdSubsetDoc
 #' @inheritParams nameDoc
+#' @inheritParams keepOriginalCohortsDoc
 #' @param matchSex Whether to match in sex.
 #' @param matchYearOfBirth Whether to match in year of birth.
 #' @param ratio Number of allowed matches per individual in the target cohort.
@@ -34,6 +35,7 @@ matchCohorts <- function(cohort,
                          matchSex = TRUE,
                          matchYearOfBirth = TRUE,
                          ratio = 1,
+                         keepOriginalCohorts = FALSE,
                          name = tableName(cohort)) {
   cli::cli_inform("Starting matching")
 
@@ -64,6 +66,10 @@ matchCohorts <- function(cohort,
   tablePrefix <- omopgenerics::tmpPrefix()
   target <- omopgenerics::uniqueTableName(tablePrefix)
   control <- omopgenerics::uniqueTableName(tablePrefix)
+  if (keepOriginalCohorts) {
+    keep <- omopgenerics::uniqueTableName(tablePrefix)
+    cdm[[keep]] <- subsetCohorts(cohort, cohortId, name = keep)
+  }
 
   if (cohort |> settings() |> nrow() == 0) {
     cdm[[name]] <- cohort |>
@@ -166,8 +172,10 @@ matchCohorts <- function(cohort,
     )
 
   # Bind both cohorts
-  cli::cli_inform(c("Binding both cohorts"))
-  cdm <- omopgenerics::bind(cdm[[target]], cdm[[control]], name = name)
+  cli::cli_inform(c("Binding cohorts"))
+  cohorts <- list(cdm[[target]], cdm[[control]])
+  if (keepOriginalCohorts) cohorts <- c(list(cdm[[keep]]), cohorts)
+  cdm <- do.call(omopgenerics::bind, c(cohorts, "name" = name))
 
   # drop tmp tables
   omopgenerics::dropTable(cdm = cdm, name = dplyr::starts_with(tablePrefix))

R/unionCohorts.R

@@ -9,11 +9,9 @@
 #' @inheritParams cohortIdSubsetDoc
 #' @inheritParams gapDoc
 #' @inheritParams nameDoc
+#' @inheritParams keepOriginalCohortsDoc
 #' @param cohortName Name of the returned cohort. If NULL, the cohort name will
 #' be created by collapsing the individual cohort names, separated by "_".
-#' @param keepOriginalCohorts If TRUE the original cohorts and the newly
-#' created union cohort will be returned. If FALSE only the new cohort will be
-#' returned.
 #'
 #' @export
 #'

tests/testthat/test-matchCohorts.R

@@ -276,3 +276,36 @@ test_that("test exactMatchingCohort with a ratio bigger than 1", {
 
   PatientProfiles::mockDisconnect(cdm)
 })
+
+test_that("keepOriginalCohorts works" , {
+  cdm <- mockCohortConstructor()
+  cohort <- cdm$cohort2 |> matchCohorts(cohortId = 1, keepOriginalCohorts = TRUE, name = "new_cohort")
+  expect_equal(
+    settings(cohort),
+    dplyr::tibble(
+      cohort_definition_id = as.integer(1:3),
+      cohort_name = c("cohort_1", "cohort_1_matched", "matched_to_cohort_1"),
+      target_table_name = c(NA, rep("cohort2", 2)),
+      target_cohort_id = c(NA, 1L, 1L),
+      target_cohort_name = c(NA, "cohort_1_matched", "cohort_1_matched"),
+      match_sex = c(NA, rep(TRUE, 2)),
+      match_year_of_birth = c(NA, rep(TRUE, 2)),
+      match_status = c(NA, "target", "control")
+    )
+  )
+  cohort <- cdm$cohort2 |> matchCohorts(keepOriginalCohorts = TRUE)
+  expect_equal(
+    settings(cohort),
+    dplyr::tibble(
+      cohort_definition_id = as.integer(1:6),
+      cohort_name = c("cohort_1", "cohort_2", "cohort_1_matched", "cohort_2_matched", "matched_to_cohort_1", "matched_to_cohort_2"),
+      target_table_name = c(NA, NA, rep("cohort2", 4)),
+      target_cohort_id = c(NA, NA, 1L, 2L, 1L, 2L),
+      target_cohort_name = c(NA, NA, "cohort_1_matched", "cohort_2_matched", "cohort_1_matched", "cohort_2_matched"),
+      match_sex = c(NA, NA, rep(TRUE, 4)),
+      match_year_of_birth = c(NA, NA, rep(TRUE, 4)),
+      match_status = c(NA, NA, "target", "target", "control", "control")
+    )
+  )
+  PatientProfiles::mockDisconnect(cdm)
+})