From 2edb680b587ece19a76141f04941468eb0a7519d Mon Sep 17 00:00:00 2001
From: edward-burn <edburn@hotmail.co.uk>
Date: Sun, 26 Jan 2025 14:43:48 +0000
Subject: [PATCH] copyCohorts

---
 R/copyCohorts.R                   | 32 ++++++++++
 _pkgdown.yml                      |  3 +
 tests/testthat/test-copyCohorts.R | 97 +++++++++++++++++++++++++++++++
 3 files changed, 132 insertions(+)
 create mode 100644 R/copyCohorts.R
 create mode 100644 tests/testthat/test-copyCohorts.R

diff --git a/R/copyCohorts.R b/R/copyCohorts.R
new file mode 100644
index 0000000..340c787
--- /dev/null
+++ b/R/copyCohorts.R
@@ -0,0 +1,32 @@
+#' Copy a cohort table
+#'
+#' @description
+#' `copyCohorts()` copies an existing cohort table to a new location.
+#'
+#' @inheritParams cohortDoc
+#' @inheritParams nameDoc
+#' @inheritParams cohortIdModifyDoc
+#'
+#' @return A new cohort table containing cohorts from the original cohort table.
+#' @export
+#'
+#' @examples
+copyCohorts <- function(cohort, name, cohortId = NULL) {
+  omopgenerics::validateCohortArgument(cohort)
+  cdm <- omopgenerics::cdmReference(cohort)
+  if(name == omopgenerics::tableName(cohort)){
+    cli::cli_abort("Cohort cannot be copied to the same table. Please provide a different name.")
+  }
+  omopgenerics::validateNameArgument(name, cdm = cdm, validation = "warning")
+  cohorts_to_keep <- omopgenerics::validateCohortIdArgument(cohortId, cohort = cohort)
+
+  if (length(unique(cohorts_to_keep)) == length(settings(cohort) |>
+    dplyr::pull("cohort_definition_id"))) {
+    # copy all cohorts
+    return(cohort |>
+      dplyr::compute(name = name, temporary = FALSE, overwrite = TRUE))
+  } else {
+    cohort |>
+      CohortConstructor::subsetCohorts(cohortId = cohorts_to_keep, name = name)
+  }
+}
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 6bcabde..6090403 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -40,6 +40,9 @@ reference:
 - subtitle: Filter cohorts
 - contents:
   - matches("subsetCohorts|sampleCohorts")
+- subtitle: Copy cohorts
+- contents:
+  - matches("copyCohorts")
 - subtitle: Split cohorts
 - contents:
   - matches("yearCohorts|stratifyCohorts")
diff --git a/tests/testthat/test-copyCohorts.R b/tests/testthat/test-copyCohorts.R
new file mode 100644
index 0000000..f806161
--- /dev/null
+++ b/tests/testthat/test-copyCohorts.R
@@ -0,0 +1,97 @@
+test_that("simple example", {
+  skip_on_cran()
+  cdm_local <- omock::mockCdmReference() |>
+    omock::mockPerson(n = 4, seed = 1) |>
+    omock::mockObservationPeriod(seed = 1) |>
+    omock::mockCohort(name = c("original_cohort"),
+                      numberCohorts = 2, seed = 1)
+  cdm <- cdm_local |> copyCdm()
+
+  start_settings <- omopgenerics::settings(cdm$original_cohort)
+  start_attrition <- omopgenerics::attrition(cdm$original_cohort)
+
+  cdm$copy_cohort <- copyCohorts(cdm$original_cohort,
+                                name = "copy_cohort")
+  expect_identical(omopgenerics::settings(cdm$copy_cohort),
+                   start_settings)
+  expect_identical(omopgenerics::attrition(cdm$copy_cohort),
+                   start_attrition)
+
+  # attrition for original cohort table should be unaffected by applying filter to copy cohort
+  cdm$copy_cohort <- cdm$copy_cohort |>
+    dplyr::filter(subject_id == 99) |>
+    omopgenerics::recordCohortAttrition("filter")
+  expect_identical(omopgenerics::attrition(cdm$original_cohort),
+                   start_attrition)
+  # original cohort table should be unaffected by applying filter to copy cohort
+  cdm$copy_cohort <- cdm$copy_cohort |>
+    requireAge(c(0,80))
+  expect_identical(omopgenerics::settings(cdm$original_cohort),
+                   start_settings)
+
+  # warning if the new cohort table already exists
+ expect_warning(cdm$copy_cohort <- copyCohorts(cdm$original_cohort,
+                                name = "copy_cohort"))
+
+ # expected errors
+ expect_error(cdm$copy_cohort <- copyCohorts(cdm$original_cohort,
+                                            name = "another_name"))
+ expect_error(cdm$copy_cohort <- copyCohorts("a",
+                                            name = "copy_cohort"))
+ # not allowed to copy cohort to the same location
+ expect_error(cdm$original_cohort <- copyCohorts(cdm$original_cohort,
+                                                name = "original_cohort"))
+
+ PatientProfiles::mockDisconnect(cdm)
+
+  })
+
+test_that("copy only specific cohort IDs", {
+  skip_on_cran()
+
+  cdm_local <- omock::mockCdmReference() |>
+    omock::mockPerson(n = 4, seed = 1) |>
+    omock::mockObservationPeriod(seed = 1) |>
+    omock::mockCohort(name = c("original_cohort"),
+                      numberCohorts = 2, seed = 1)
+  cdm <- cdm_local |> copyCdm()
+
+  start_settings <- omopgenerics::settings(cdm$original_cohort)
+  start_attrition <- omopgenerics::attrition(cdm$original_cohort)
+
+  # keep just one cohort
+  cdm$copy_cohort_a <- copyCohorts(cdm$original_cohort,
+                                cohortId = 1,
+                                name = "copy_cohort_a")
+  cdm$copy_cohort_b <- copyCohorts(cdm$original_cohort,
+                                cohortId = "cohort_1",
+                                name = "copy_cohort_b")
+  expect_identical(
+    omopgenerics::settings(cdm$original_cohort) |>
+      dplyr::filter(cohort_definition_id == 1),
+    omopgenerics::settings(cdm$copy_cohort_a))
+  expect_identical(
+    omopgenerics::settings(cdm$original_cohort) |>
+      dplyr::filter(cohort_name == "cohort_1"),
+    omopgenerics::settings(cdm$copy_cohort_b))
+
+  # keep both cohorts
+  cdm$copy_cohort_c <- copyCohorts(cdm$original_cohort,
+                                cohortId = c(1, 2),
+                                name = "copy_cohort_c")
+  cdm$copy_cohort_d <- copyCohorts(cdm$original_cohort,
+                                cohortId = c("cohort_1", "cohort_2"),
+                                name = "copy_cohort_d")
+
+  # cohort not present
+  expect_error(cdm$copy_cohort <- copyCohorts(cdm$original_cohort,
+                                cohortId = c(3),
+                                name = "copy_cohort"))
+  expect_error(cdm$copy_cohort <- copyCohorts(cdm$original_cohort,
+                                             cohortId = "not_a_cohort",
+                                             name = "copy_cohort"))
+
+  PatientProfiles::mockDisconnect(cdm)
+
+})
+