From e7305cfd16af0a1129f198eca17e4fd3d33e92bf Mon Sep 17 00:00:00 2001 From: MimiYuchenGuo Date: Mon, 11 Dec 2023 13:13:31 +0000 Subject: [PATCH] issues 7, 10, 11 --- R/generateCombinationCohorts.R | 25 +- R/requireDemographics.R | 302 ++++++++++++------ man/generateCombinationCohortSet.Rd | 7 +- .../test-generateCombinationCohorts.R | 42 +++ tests/testthat/test-requireDemographics.R | 216 +++++++++---- 5 files changed, 422 insertions(+), 170 deletions(-) diff --git a/R/generateCombinationCohorts.R b/R/generateCombinationCohorts.R index fd476a3b..6c451c72 100644 --- a/R/generateCombinationCohorts.R +++ b/R/generateCombinationCohorts.R @@ -7,9 +7,9 @@ #' combinations. #' @param targetCohortId Ids to combine of the target cohort. If NULL all #' cohort present in the table will be used. -#' @param mutuallyExclusive Wheather the generated cohorts are mutually +#' @param mutuallyExclusive Whether the generated cohorts are mutually #' exclusive or not. -#' +#' @param returnOnlyComb Whether to only get the combination cohort back #' @export #' #' @return The cdm object with the new generated cohort set @@ -36,7 +36,8 @@ generateCombinationCohortSet <- function(cdm, name, targetCohortName, targetCohortId = NULL, - mutuallyExclusive = FALSE) { + mutuallyExclusive = FALSE, + returnOnlyComb = FALSE) { # initial checks checkmate::checkClass(cdm, "cdm_reference") checkmate::checkCharacter(name, len = 1, any.missing = FALSE, min.chars = 1) @@ -95,7 +96,7 @@ generateCombinationCohortSet <- function(cdm, nameStyle = "{cohort_name}" ) - # cretae cohort_definition_id + # create cohort_definition_id cohortNames <- CDMConnector::cohortSet(cdm[[targetCohortName]]) %>% dplyr::filter(.data$cohort_definition_id %in% .env$targetCohortId) %>% dplyr::pull("cohort_name") @@ -112,13 +113,22 @@ generateCombinationCohortSet <- function(cdm, cohSet <- notMutuallyEclusiveCohortSet(cohSet) } + + if (returnOnlyComb) { + cohSet <- cohSet %>% + dplyr::rowwise() %>% + dplyr::mutate(product = prod(dplyr::c_across(-"cohort_definition_id"), na.rm = TRUE)) %>% + dplyr::filter(.data$product == 1) %>% + dplyr::select(-"product") + } + + # add cohort definition id cohort <- cohort %>% dplyr::inner_join(cohSet, copy = TRUE, by = cohortNames) %>% dplyr::select( "cohort_definition_id", "subject_id", "cohort_start_date", - "cohort_end_date" - ) + "cohort_end_date") if (!mutuallyExclusive) { cohort <- joinOverlap(x = cohort, gap = 1) @@ -132,7 +142,8 @@ generateCombinationCohortSet <- function(cdm, dplyr::distinct() } - cohort <- cohort %>% + + cohort <- cohort %>% CDMConnector::computeQuery( name = name, temporary = FALSE, diff --git a/R/requireDemographics.R b/R/requireDemographics.R index ece6dd60..f9ddfae6 100644 --- a/R/requireDemographics.R +++ b/R/requireDemographics.R @@ -22,14 +22,33 @@ requireDemographics <- function(cohort, ageRange = list(c(0, 150)), sex = c("Both"), minPriorObservation = 0, - minFutureObservation = 0){ - - cohort <- demographicsFilter(cohort = cohort, - indexDate = indexDate, - ageRange = ageRange, - sex = sex, - minPriorObservation = minPriorObservation, - minFutureObservation = minFutureObservation) + minFutureObservation = 0) { + external_cols <- cohort %>% + dplyr::select(-c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date", + indexDate + )) %>% + colnames() + + cohort <- demographicsFilter( + cohort = cohort, + indexDate = indexDate, + ageRange = ageRange, + sex = sex, + minPriorObservation = minPriorObservation, + minFutureObservation = minFutureObservation + ) + + + if (length(external_cols) > 0) { + if (!all(external_cols %in% (cohort %>% colnames()))) { + cli::cli_abort(paste0( + "Missing original column ", + setdiff(external_cols, cohort %>% colnames()) + )) + } + } cohort <- cohort %>% CDMConnector::recordCohortAttrition(reason = "Demographic requirements") @@ -50,21 +69,23 @@ requireDemographics <- function(cohort, #' @examples requireAge <- function(cohort, indexDate = "cohort_start_date", - ageRange = list(c(0, 150))){ - - cohort <- demographicsFilter(cohort = cohort, - indexDate = indexDate, - ageRange = ageRange, - sex = "Both", - minPriorObservation = 0, - minFutureObservation = 0) + ageRange = list(c(0, 150))) { + cohort <- demographicsFilter( + cohort = cohort, + indexDate = indexDate, + ageRange = ageRange, + sex = "Both", + minPriorObservation = 0, + minFutureObservation = 0 + ) cohort <- cohort %>% - CDMConnector::recordCohortAttrition(reason = - glue::glue("Age requirement: {ageRange[[1]][1]} to {ageRange[[1]][2]}")) + CDMConnector::recordCohortAttrition( + reason = + glue::glue("Age requirement: {ageRange[[1]][1]} to {ageRange[[1]][2]}") + ) cohort - } #' Restrict cohort on sex @@ -78,22 +99,24 @@ requireAge <- function(cohort, #' #' @examples requireSex <- function(cohort, - sex = c("Both")){ - - cohort <- demographicsFilter(cohort = cohort, - indexDate = "cohort_start_date", - ageRange = list(c(0, 150)), - sex = sex, - minPriorObservation = 0, - minFutureObservation = 0) + sex = c("Both")) { + cohort <- demographicsFilter( + cohort = cohort, + indexDate = "cohort_start_date", + ageRange = list(c(0, 150)), + sex = sex, + minPriorObservation = 0, + minFutureObservation = 0 + ) cohort <- cohort %>% - CDMConnector::recordCohortAttrition(reason = - glue::glue("Sex requirement: {sex}")) + CDMConnector::recordCohortAttrition( + reason = + glue::glue("Sex requirement: {sex}") + ) cohort - } #' Restrict cohort on prior observation @@ -110,21 +133,23 @@ requireSex <- function(cohort, #' @examples requirePriorObservation <- function(cohort, indexDate = "cohort_start_date", - minPriorObservation = 0){ - - cohort <- demographicsFilter(cohort = cohort, - indexDate = indexDate, - ageRange = list(c(0, 150)), - sex = "Both", - minPriorObservation = minPriorObservation, - minFutureObservation = 0) + minPriorObservation = 0) { + cohort <- demographicsFilter( + cohort = cohort, + indexDate = indexDate, + ageRange = list(c(0, 150)), + sex = "Both", + minPriorObservation = minPriorObservation, + minFutureObservation = 0 + ) cohort <- cohort %>% - CDMConnector::recordCohortAttrition(reason = - glue::glue("Prior observation requirement: {minPriorObservation} days")) + CDMConnector::recordCohortAttrition( + reason = + glue::glue("Prior observation requirement: {minPriorObservation} days") + ) cohort - } #' Restrict cohort on future observation @@ -141,79 +166,82 @@ requirePriorObservation <- function(cohort, #' @examples requireFutureObservation <- function(cohort, indexDate = "cohort_start_date", - minFutureObservation = 0){ - - cohort <- demographicsFilter(cohort = cohort, - indexDate = indexDate, - ageRange = list(c(0, 150)), - sex = "Both", - minPriorObservation = 0, - minFutureObservation = minFutureObservation) + minFutureObservation = 0) { + cohort <- demographicsFilter( + cohort = cohort, + indexDate = indexDate, + ageRange = list(c(0, 150)), + sex = "Both", + minPriorObservation = 0, + minFutureObservation = minFutureObservation + ) cohort <- cohort %>% - CDMConnector::recordCohortAttrition(reason = - glue::glue("Future observation requirement: {minFutureObservation} days")) + CDMConnector::recordCohortAttrition( + reason = + glue::glue("Future observation requirement: {minFutureObservation} days") + ) cohort - } demographicsFilter <- function(cohort, - indexDate, - ageRange, - sex, - minPriorObservation, - minFutureObservation){ - + indexDate, + ageRange, + sex, + minPriorObservation, + minFutureObservation) { cdm <- attr(cohort, "cdm_reference") # validate inputs if (!isTRUE(inherits(cdm, "cdm_reference"))) { cli::cli_abort("cohort must be part of a cdm reference") } - if(!"GeneratedCohortSet" %in% class(cohort) || - !all(c("cohort_definition_id", "subject_id", - "cohort_start_date", "cohort_end_date") %in% - colnames(cohort))){ + if (!"GeneratedCohortSet" %in% class(cohort) || + !all(c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date" + ) %in% + colnames(cohort))) { cli::cli_abort("cohort must be a GeneratedCohortSet") } - if(!indexDate %in% colnames(cohort)){ + if (!indexDate %in% colnames(cohort)) { cli::cli_abort("indexDate must be a date column in the cohort table") } - if(!is.list(ageRange)){ + if (!is.list(ageRange)) { cli::cli_abort("ageRange must be a list") } - if(length(ageRange[[1]]) != 2 || - !is.numeric(ageRange[[1]]) || - !ageRange[[1]][2] >= ageRange[[1]][1] || - !ageRange[[1]][1]>=0){ + if (length(ageRange[[1]]) != 2 || + !is.numeric(ageRange[[1]]) || + !ageRange[[1]][2] >= ageRange[[1]][1] || + !ageRange[[1]][1] >= 0) { cli::cli_abort("ageRange only contain a vector of length two, with the second number greater or equal to the first") } - if(length(ageRange) != 1){ + if (length(ageRange) != 1) { cli::cli_abort("Only a single ageRange is currently supported") } - if(!all(sex %in% c("Both", "Male", "Female"))){ + if (!all(sex %in% c("Both", "Male", "Female"))) { cli::cli_abort("sex must be Both, Male, or Female") } - if(length(sex) != 1){ + if (length(sex) != 1) { cli::cli_abort("Only a single sex option is currently supported") } - if(!is.numeric(minPriorObservation) || - length(minPriorObservation) != 1 || - !minPriorObservation >= 0){ + if (!is.numeric(minPriorObservation) || + length(minPriorObservation) != 1 || + !minPriorObservation >= 0) { cli::cli_abort("minPriorObservation must be a positive number") } - if(!is.numeric(minFutureObservation) || - length(minFutureObservation) != 1 || - !minFutureObservation >= 0){ + if (!is.numeric(minFutureObservation) || + length(minFutureObservation) != 1 || + !minFutureObservation >= 0) { cli::cli_abort("minFutureObservation must be a positive number") } minAge <- ageRange[[1]][1] maxAge <- ageRange[[1]][2] - if(sex == "Both"){ + if (sex == "Both") { sex <- c("Male", "Female") } @@ -222,22 +250,112 @@ demographicsFilter <- function(cohort, # join later working_cohort <- cohort %>% - dplyr::select(dplyr::all_of(c("cohort_definition_id", "subject_id", - "cohort_start_date", "cohort_end_date", - indexDate))) %>% + dplyr::select(c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date", + indexDate + )) %>% PatientProfiles::addDemographics(indexDate = indexDate) %>% - dplyr::filter(.data$age >= .env$minAge, - .data$age <= .env$maxAge, - .data$sex %in% .env$sex, - .data$prior_observation >= .env$minPriorObservation, - .data$future_observation >= .env$minFutureObservation) + dplyr::filter( + .data$age >= .env$minAge, + .data$age <= .env$maxAge, + .data$sex %in% .env$sex, + .data$prior_observation >= .env$minPriorObservation, + .data$future_observation >= .env$minFutureObservation + ) cohort <- cohort %>% - dplyr::inner_join(working_cohort %>% - dplyr::select(dplyr::all_of(c("cohort_definition_id", - "subject_id", - "cohort_start_date", "cohort_end_date"))), - by = c("cohort_definition_id", "subject_id", - "cohort_start_date", "cohort_end_date")) + dplyr::inner_join( + working_cohort %>% + dplyr::select(c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date" + )), + by = c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date" + ) + ) cohort } + + +requireDateRange <- function(cohort, + indexDateName = "cohort_start_date", + endDateName = "cohort_end_date", + cohortDateRange = as.Date(c(NA, NA))) { + cdm <- attr(cohort, "cdm_reference") + + # validate inputs + if (!isTRUE(inherits(cdm, "cdm_reference"))) { + cli::cli_abort("cohort must be part of a cdm reference") + } + if (!"GeneratedCohortSet" %in% class(cohort) || + !all(c( + "cohort_definition_id", "subject_id", + "cohort_start_date", "cohort_end_date" + ) %in% + colnames(cohort))) { + cli::cli_abort("cohort must be a GeneratedCohortSet") + } + + if (!indexDateName %in% colnames(cohort)) { + cli::cli_abort(paste0(indexDateName, " must be a date column in the cohort table")) + } + + if (!endDateName %in% colnames(cohort)) { + cli::cli_abort(paste0(endDateName, " must be a date column in the cohort table")) + } + + + cohort <- trimStartDate(cohort, + cdm, + indexDateName, + endDateName, + startDate = cohortDateRange[1] + ) + cohort <- cohort %>% + CDMConnector::recordCohortAttrition(reason = paste0( + indexDateName, + " >= ", cohortDateRange[1] + )) + + cohort <- trimEndDate( + cohort, + cdm, + indexDateName, + endDateName, + cohortDateRange[2] + ) + + cohort <- cohort %>% + CDMConnector::recordCohortAttrition(reason = paste0( + indexDateName, + " <= ", cohortDateRange[2] + )) +} + + +trimStartDate <- function(cohort, cdm, indexDateName, endDateName, startDate) { + if (!is.na(startDate)) { + cohort <- cohort %>% + dplyr::mutate(!!indexDateName := dplyr::if_else( + .data[[indexDateName]] <= !!startDate, + as.Date(startDate), .data[[indexDateName]] + )) %>% + dplyr::filter(.data[[indexDateName]] <= .data[[endDateName]]) + } + return(cohort) +} + +trimEndDate <- function(cohort, cdm, indexDateName, endDateName, endDate) { + if (!is.na(endDate)) { + cohort <- cohort %>% + dplyr::mutate(!!endDateName := dplyr::if_else( + .data[[endDateName]] >= !!endDate, + as.Date(endDate), .data[[endDateName]] + )) %>% + dplyr::filter(.data[[indexDateName]] <= .data[[endDateName]]) + } + return(cohort) +} diff --git a/man/generateCombinationCohortSet.Rd b/man/generateCombinationCohortSet.Rd index 766e0d13..e828ea78 100644 --- a/man/generateCombinationCohortSet.Rd +++ b/man/generateCombinationCohortSet.Rd @@ -10,7 +10,8 @@ generateCombinationCohortSet( name, targetCohortName, targetCohortId = NULL, - mutuallyExclusive = FALSE + mutuallyExclusive = FALSE, + returnOnlyComb = FALSE ) } \arguments{ @@ -24,8 +25,10 @@ combinations.} \item{targetCohortId}{Ids to combine of the target cohort. If NULL all cohort present in the table will be used.} -\item{mutuallyExclusive}{Wheather the generated cohorts are mutually +\item{mutuallyExclusive}{Whether the generated cohorts are mutually exclusive or not.} + +\item{returnOnlyComb}{Whether to only get the combination cohort back} } \value{ The cdm object with the new generated cohort set diff --git a/tests/testthat/test-generateCombinationCohorts.R b/tests/testthat/test-generateCombinationCohorts.R index 781466cd..cf8c07dd 100644 --- a/tests/testthat/test-generateCombinationCohorts.R +++ b/tests/testthat/test-generateCombinationCohorts.R @@ -187,3 +187,45 @@ test_that("generateCombinationCohortSet", { CDMConnector::cdmDisconnect(cdm) }) + + + + +test_that("only return comb", { + cohort <- dplyr::tibble( + cohort_definition_id = c(1, 2, 3), + subject_id = c(1, 1, 1), + cohort_start_date = as.Date(c( + "2020-03-01", "2020-01-01", "2020-03-01" + )), + cohort_end_date = as.Date(c( + "2020-05-01", "2020-05-02", "2020-04-01" + )) + ) + person <- dplyr::tibble( + person_id = c(1, 2, 3, 4), + gender_concept_id = c(8507, 8532, 8507, 8532), + year_of_birth = 2000, + month_of_birth = 1, + day_of_birth = 1 + ) + observation_period <- dplyr::tibble( + observation_period_id = 1:4, + person_id = 1:4, + observation_period_start_date = as.Date("2020-01-01"), + observation_period_end_date = as.Date("2020-12-31") + ) + cdm <- PatientProfiles::mockPatientProfiles( + observation_period = observation_period, person = person, cohort1 = cohort + ) + + cdm <- generateCombinationCohortSet( + cdm = cdm, name = "cohort2", targetCohortName = "cohort1", + mutuallyExclusive = FALSE, returnOnlyComb = TRUE + ) + + expect_true(all(cdm$cohort2 %>% dplyr::pull(cohort_start_date) == as.Date("2020-03-01"))) + + expect_true(all(cdm$cohort2 %>% dplyr::pull(cohort_end_date) == as.Date("2020-04-01"))) + +}) diff --git a/tests/testthat/test-requireDemographics.R b/tests/testthat/test-requireDemographics.R index 0266fe9c..b0c58665 100644 --- a/tests/testthat/test-requireDemographics.R +++ b/tests/testthat/test-requireDemographics.R @@ -1,66 +1,100 @@ test_that("simple example", { - cdm <- PatientProfiles::mockPatientProfiles(patient_size = 100, - drug_exposure_size = 100) - cdm$cohort1 <- cdm$cohort1 %>% - requireDemographics(ageRange = list(c(0,50)), - indexDate = "cohort_start_date", - sex = "Both", - minPriorObservation = 10, - minFutureObservation = 5) - - expect_true("GeneratedCohortSet" %in% class(cdm$cohort1)) - - cdm$cohort1 <- cdm$cohort1 %>% - requireAge(ageRange = list(c(10,40))) %>% - requireSex(sex = "Male") %>% - requirePriorObservation(minPriorObservation = 20) %>% - requireFutureObservation(minFutureObservation = 10) - - # expect errors - expect_error(requireDemographics(cohort = "cohort")) - expect_error(requireDemographics(cohort = cdm$person)) - expect_error(requireDemographics(cohort = cdm$cohort2, - indexDate = "aaa")) - expect_error(requireDemographics(cohort = cdm$cohort2, - ageRange = c(0,50))) - expect_error(requireDemographics(cohort = cdm$cohort2, - ageRange = list(c(50,40)))) - expect_error(requireDemographics(cohort = cdm$cohort2, - ageRange = list(c(-10,40)))) - expect_error(requireDemographics(cohort = cdm$cohort2, - ageRange = list(c(0,"a")))) - expect_error(requireDemographics(cohort = cdm$cohort2, - sex = "a")) - - expect_error(requireDemographics(cohort = cdm$cohort2, - minPriorObservation = -10)) - expect_error(requireDemographics(cohort = cdm$cohort2, - minPriorObservation = "a")) - expect_error(requireDemographics(cohort = cdm$cohort2, - minFutureObservation = -10)) - expect_error(requireDemographics(cohort = cdm$cohort2, - minFutureObservation = "a")) - - # multiple options not currently supported - expect_error(requireDemographics(cohort = cdm$cohort2, - ageRange = list(c(0,50), - c(51,100)))) - expect_error(requireDemographics(cohort = cdm$cohort2, - sex = c("Both", "Male"))) - expect_error(requireDemographics(cohort = cdm$cohort2, - minPriorObservation = c(0,10))) - expect_error(requireDemographics(cohort = cdm$cohort2, - minFutureObservation = c(0,10))) - - CDMConnector::cdm_disconnect(cdm) - }) + cdm <- PatientProfiles::mockPatientProfiles( + patient_size = 100, + drug_exposure_size = 100 + ) + cdm$cohort1 <- cdm$cohort1 %>% + requireDemographics( + ageRange = list(c(0, 50)), + indexDate = "cohort_start_date", + sex = "Both", + minPriorObservation = 10, + minFutureObservation = 5 + ) + + expect_true("GeneratedCohortSet" %in% class(cdm$cohort1)) + + cdm$cohort1 <- cdm$cohort1 %>% + requireAge(ageRange = list(c(10, 40))) %>% + requireSex(sex = "Male") %>% + requirePriorObservation(minPriorObservation = 20) %>% + requireFutureObservation(minFutureObservation = 10) + + # expect errors + expect_error(requireDemographics(cohort = "cohort")) + expect_error(requireDemographics(cohort = cdm$person)) + expect_error(requireDemographics( + cohort = cdm$cohort2, + indexDate = "aaa" + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + ageRange = c(0, 50) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + ageRange = list(c(50, 40)) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + ageRange = list(c(-10, 40)) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + ageRange = list(c(0, "a")) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + sex = "a" + )) + + expect_error(requireDemographics( + cohort = cdm$cohort2, + minPriorObservation = -10 + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + minPriorObservation = "a" + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + minFutureObservation = -10 + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + minFutureObservation = "a" + )) + + # multiple options not currently supported + expect_error(requireDemographics( + cohort = cdm$cohort2, + ageRange = list( + c(0, 50), + c(51, 100) + ) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + sex = c("Both", "Male") + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + minPriorObservation = c(0, 10) + )) + expect_error(requireDemographics( + cohort = cdm$cohort2, + minFutureObservation = c(0, 10) + )) + + CDMConnector::cdm_disconnect(cdm) +}) test_that("restrictions applied to single cohort", { # one person, one observation periods personTable <- dplyr::tibble( person_id = c("1", "2", "3"), - gender_concept_id = c("8507","8532","8507"), - year_of_birth = c(2000,2005,2010), + gender_concept_id = c("8507", "8532", "8507"), + year_of_birth = c(2000, 2005, 2010), month_of_birth = 01, day_of_birth = 01 ) @@ -77,29 +111,73 @@ test_that("restrictions applied to single cohort", { cohort_end_date = as.Date(c("2013-06-06", "2013-06-06", "2013-02-01")) ) - cdm <- PatientProfiles::mockPatientProfiles(person = personTable, - observation_period = observationPeriodTable, - cohort1 = cohortTable) + cdm <- PatientProfiles::mockPatientProfiles( + person = personTable, + observation_period = observationPeriodTable, + cohort1 = cohortTable + ) cdm$cohort1 <- cdm$cohort1 %>% - requireDemographics(ageRange = list(c(0,5))) + requireDemographics(ageRange = list(c(0, 5))) - expect_equal(c("2", "3"), - sort(cdm$cohort1 %>% - dplyr::pull("subject_id"))) + expect_equal( + c("2", "3"), + sort(cdm$cohort1 %>% + dplyr::pull("subject_id")) + ) cdm$cohort1 <- cdm$cohort1 %>% requireDemographics(sex = "Male") - expect_equal(c("3"), - sort(cdm$cohort1 %>% - dplyr::pull("subject_id"))) + expect_equal( + c("3"), + sort(cdm$cohort1 %>% + dplyr::pull("subject_id")) + ) CDMConnector::cdm_disconnect(cdm) - }) test_that("ignore existing cohort extra variables", { - # ignore existing conflicting age column, but keep it in the output +}) + + + +test_that("requireDateRange", { + # one person, one observation periods + + cohortTable <- dplyr::tibble( + cohort_definition_id = c(1, 1, 1), + subject_id = c("1", "2", "3"), + cohort_start_date = as.Date(c("2010-06-06", "2010-06-06", "2010-06-08")), + cohort_end_date = as.Date(c("2013-06-06", "2013-06-06", "2013-02-01")) + ) + + cdm <- PatientProfiles::mockPatientProfiles(cohort1 = cohortTable) + cdm$cohort1 <- cdm$cohort1 %>% + requireDateRange(cohortDateRange = as.Date(c("2010-06-06", "2013-02-01"))) + + expect_true(all(cdm$cohort1 %>% dplyr::pull(cohort_start_date) == + as.Date(c("2010-06-06", "2010-06-06", "2010-06-08")))) + + CDMConnector::cdm_disconnect(cdm) +}) + + + +test_that("external columns kept after requireDemographics", { + cdm <- PatientProfiles::mockPatientProfiles( + patient_size = 100, + drug_exposure_size = 100 + ) + cdm$cohort1 <- cdm$cohort1 %>% dplyr::mutate( + col_extra1 = as.numeric(subject_id) + 1, + col_extra2 = as.numeric(subject_id) + 2 + ) + + + cdm$cohort1 <- cdm$cohort1 %>% + requireDemographics() + expect_true(all(c("col_extra1", "col_extra2") %in% colnames(cdm$cohort1))) })