Merge pull request #355 from OHDSI/test_within_observation

Test union, collapse and intersect work with multiple observation periods

R/intersectCohorts.R

@@ -131,8 +131,12 @@ intersectCohorts <- function(cohort,
  dplyr::compute(name = tblName, temporary = FALSE)
  if (cohortOut |> dplyr::tally() |> dplyr::pull("n") > 0) {
  cohortOut <- cohortOut %>%
- dplyr::compute(name = tblName, temporary = FALSE) |>
- joinOverlap(name = tblName, gap = gap)
+ PatientProfiles::addObservationPeriodId(name = tblName) |>
+ joinOverlap(
+ name = tblName, gap = gap,
+ by = c("observation_period_id", "cohort_definition_id", "subject_id")
+ ) |>
+ dplyr::select(!"observation_period_id")
  }
 
  # attributes

R/mockCohortConstructor.R

@@ -56,7 +56,7 @@ mockCohortConstructor <- function(nPerson = 10,
  }
 
  if (!is.null(conceptIdClass) && !is.null(conceptId)) {
- cdm <- cdm |> omock::mockConcepts(conceptSet = conceptId, domain = conceptIdClass)
+ cdm <- cdm |> omock::mockConcepts(conceptSet = conceptId, domain = conceptIdClass, seed = seed)
  }
 
  if (drugExposure) {

R/unionCohorts.R

@@ -63,9 +63,11 @@ unionCohorts <- function(cohort,
  tmpTable <- omopgenerics::uniqueTableName()
  unionedCohort <- cohort |>
  dplyr::filter(.data$cohort_definition_id %in% .env$cohortId) |>
+ PatientProfiles::addObservationPeriodId(name = tmpTable) |>
  joinOverlap(name = tmpTable,
- by = "subject_id",
+ by = c("observation_period_id", "subject_id"),
  gap = gap) |>
+ dplyr::select(!"observation_period_id") |>
  dplyr::mutate(cohort_definition_id = 1L) |>
  dplyr::relocate(dplyr::all_of(omopgenerics::cohortColumns("cohort"))) |>
  dplyr::compute(name = tmpTable, temporary = FALSE)

tests/testthat/test-collapseCohorts.R

@@ -307,5 +307,6 @@ test_that("multiple observation periods", {
  expect_true(nrow(cdm$cohort_1 |>
  dplyr::collect()) == 2)
 
+ PatientProfiles::mockDisconnect(cdm)
 
 })

tests/testthat/test-intersectCohorts.R

@@ -434,7 +434,7 @@ test_that("codelist", {
  cdm_local <- omock::mockCdmReference() |>
  omock::mockPerson(n = 3) |>
  omock::mockObservationPeriod() |>
- omock::mockCohort()
+ omock::mockCohort(seed = 1)
  cdm_local$concept <- dplyr::tibble(
  "concept_id" = c(1, 2, 3),
  "concept_name" = c("my concept 1", "my concept 2", "my concept 3"),
@@ -457,8 +457,8 @@ test_that("codelist", {
  "drug_exposure_start_date" = as.Date(.data$drug_exposure_start_date, origin = "2010-01-01"),
  "drug_exposure_end_date" = as.Date(.data$drug_exposure_end_date, origin = "2010-01-01")
  )
- cdm_local$observation_period <- cdm_local$observation_period|>
- dplyr::mutate(observation_period_start_date = as.Date("1990-01-01"), observation_period_end_date = as.Date("2020-01-01"))
+ cdm_local$observation_period <- cdm_local$observation_period |>
+ dplyr::mutate(observation_period_start_date = as.Date("1980-01-01"), observation_period_end_date = as.Date("2020-01-01"))
 
  cdm <- cdm_local |> copyCdm()
 
@@ -591,3 +591,44 @@ test_that("records combined for gap must be in the same observation period", {
 
  PatientProfiles::mockDisconnect(cdm)
 })
+
+test_that("multiple observation periods", {
+ cdm_local <- omock::mockCdmReference() |>
+ omock::mockPerson(n = 4, seed = 1)
+ cdm_local$observation_period <- dplyr::tibble(
+ "observation_period_id" = as.integer(1:7),
+ "person_id" = as.integer(c(1, 1, 1, 2, 2, 3, 4)),
+ "observation_period_start_date" = as.Date(c(
+ "2000-01-01", "2001-01-01", "2003-01-01", "2001-01-01", "2002-01-01",
+ "2000-01-01", "2000-01-01"
+ )),
+ "observation_period_end_date" =as.Date(c(
+ "2000-12-20", "2002-01-01", "2005-01-01", "2001-12-31", "2004-01-01",
+ "2004-01-01", "2003-01-01"
+ )),
+ "period_type_concept_id" = NA_integer_
+ )
+ cdm_local$cohort1 <- dplyr::tibble(
+ "cohort_definition_id" = as.integer(c(1, 2, 1, 2)),
+ "subject_id" = as.integer(c(1, 1, 1, 1)),
+ "cohort_start_date" = as.Date(c(
+ "2000-01-01", "2000-12-01", "2001-01-01", "2001-01-01"
+ )),
+ "cohort_end_date" =as.Date(c(
+ "2000-12-20", "2000-12-20", "2001-04-01", "2001-12-30"
+ ))
+ )
+ cdm <- cdm_local |> copyCdm()
+ cdm$cohort1 <- cdm$cohort1 |> omopgenerics::newCohortTable()
+ cdm$cohort1 <- cdm$cohort1 |> intersectCohorts(gap = 9999)
+ expect_equal(
+ collectCohort(cdm$cohort1, 1),
+ dplyr::tibble(
+ "subject_id" = as.integer(c(1, 1)),
+ "cohort_start_date" = as.Date(c("2000-01-01", "2001-01-01")),
+ "cohort_end_date" = as.Date(c("2000-12-20", "2001-12-30"))
+ )
+ )
+
+ PatientProfiles::mockDisconnect(cdm)
+})

tests/testthat/test-unionCohorts.R

@@ -4,7 +4,7 @@ test_that("unionCohorts works", {
  omock::mockObservationPeriod(seed = 1) |>
  omock::mockCohort(name = c("cohort1"), numberCohorts = 4, seed = 1)
  cdm <- cdm_local |> copyCdm()
-  # simple example
+ # simple example
  cdm$cohort2 <- unionCohorts(cdm$cohort1, name = "cohort2")
  expect_true(all(
  cdm$cohort2 %>% dplyr::pull("cohort_start_date") %>% sort() ==
@@ -297,3 +297,43 @@ test_that("keep original cohorts", {
 
  PatientProfiles::mockDisconnect(cdm)
 })
+
+test_that("multiple observation periods", {
+ cdm_local <- omock::mockCdmReference() |>
+ omock::mockPerson(n = 4, seed = 1)
+ cdm_local$observation_period <- dplyr::tibble(
+ "observation_period_id" = as.integer(1:7),
+ "person_id" = as.integer(c(1, 1, 1, 2, 2, 3, 4)),
+ "observation_period_start_date" = as.Date(c(
+ "2000-01-01", "2001-01-01", "2003-01-01", "2001-01-01", "2002-01-01",
+ "2000-01-01", "2000-01-01"
+ )),
+ "observation_period_end_date" =as.Date(c(
+ "2000-12-20", "2002-01-01", "2005-01-01", "2001-12-31", "2004-01-01",
+ "2004-01-01", "2003-01-01"
+ )),
+ "period_type_concept_id" = NA_integer_
+ )
+ cdm_local$cohort <- dplyr::tibble(
+ "cohort_definition_id" = as.integer(c(1, 1, 1, 1, 2, 2)),
+ "subject_id" = as.integer(c(1, 1, 1, 2, 2, 1)),
+ "cohort_start_date" = as.Date(c(
+ "2000-01-01", "2000-12-01", "2001-01-01", "2001-01-01", "2002-01-01", "2003-01-01"
+ )),
+ "cohort_end_date" =as.Date(c(
+ "2000-05-20", "2000-12-20", "2001-04-01", "2001-12-30", "2003-01-01", "2004-01-01"
+ ))
+ )
+ cdm <- cdm_local |> copyCdm()
+ cdm$cohort <- cdm$cohort |> omopgenerics::newCohortTable() |> unionCohorts(gap = 99999)
+ expect_equal(
+ collectCohort(cdm$cohort, 1),
+ dplyr::tibble(
+ "subject_id" = as.integer(c(1, 1, 1, 2, 2)),
+ "cohort_start_date" = as.Date(c("2000-01-01", "2001-01-01", "2003-01-01", "2001-01-01", "2002-01-01")),
+ "cohort_end_date" = as.Date(c("2000-12-20", "2001-04-01", "2004-01-01", "2001-12-30", "2003-01-01"))
+ )
+ )
+
+ PatientProfiles::mockDisconnect(cdm)
+})