Skip to content

Commit

Permalink
add inObservation argument
Browse files Browse the repository at this point in the history
  • Loading branch information
nmercadeb committed Dec 19, 2024
1 parent 00a2db1 commit 0f455ab
Show file tree
Hide file tree
Showing 6 changed files with 102 additions and 82 deletions.
1 change: 1 addition & 0 deletions CohortConstructor.Rproj
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
Version: 1.0
ProjectId: 00fa364f-f8e3-4b28-a7dd-02de51c09f48

RestoreWorkspace: No
SaveWorkspace: No
Expand Down
2 changes: 1 addition & 1 deletion R/requireCohortIntersect.R
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
#' @inheritParams windowDoc
#' @inheritParams nameDoc
#'
#' @return Cohort table with only those isatisfying the criteria kept
#' @return Cohort table with only those entries satisfying the criteria
#'
#' @export
#'
Expand Down
4 changes: 4 additions & 0 deletions R/requireConceptIntersect.R
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,8 @@
#' @inheritParams windowDoc
#' @inheritParams nameDoc
#' @inheritParams conceptSetDoc
#' @param inObservation If TRUE only records inside an observation period will
#' be considered.
#'
#' @return Cohort table with only those with the events in the concept list
#' kept (or those without the event if negate = TRUE)
Expand All @@ -35,6 +37,7 @@ requireConceptIntersect <- function(cohort,
indexDate = "cohort_start_date",
targetStartDate = "event_start_date",
targetEndDate = "event_end_date",
inObservation = TRUE,
censorDate = NULL,
name = tableName(cohort)) {
# checks
Expand Down Expand Up @@ -82,6 +85,7 @@ requireConceptIntersect <- function(cohort,
targetEndDate = targetEndDate,
window = window,
censorDate = censorDate,
inObservation = inObservation,
nameStyle = "intersect_concept",
name = subsetName
)
Expand Down
2 changes: 1 addition & 1 deletion man/requireCohortIntersect.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

4 changes: 4 additions & 0 deletions man/requireConceptIntersect.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

171 changes: 91 additions & 80 deletions tests/testthat/test-requireConceptIntersect.R
Original file line number Diff line number Diff line change
Expand Up @@ -30,25 +30,36 @@ test_that("require flag in concept", {

start_cols <- colnames(cdm$cohort1)
cdm$cohort3 <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1),
window = c(-Inf, Inf),
name = "cohort3")
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
name = "cohort3")
expect_identical(colnames(cdm$cohort3), colnames(cdm$cohort1))
expect_true(all(cdm$cohort3 |> dplyr::pull("subject_id") == 1L))
expect_true(all(cdm$cohort3 |> dplyr::pull("cohort_start_date") |> sort() ==
c("2001-03-24", "2001-11-28", "2002-01-30", "2002-06-13", "2003-05-17", "2004-03-11")))

cdm$in_obs <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1L),
intersections = 2,
window = c(0, Inf),
inObservation = FALSE,
name = "in_obs")
expect_identical(
collectCohort(cdm$in_obs, 1),
dplyr::tibble(subject_id = 2L, cohort_start_date = as.Date("1999-05-03"), cohort_end_date = as.Date("2001-06-15"))
)

expect_true(all(omopgenerics::attrition(cdm$cohort3)$reason ==
c("Initial qualifying events",
"Concept a between -Inf & Inf days relative to cohort_start_date between 1 and Inf",
"Initial qualifying events",
"Concept a between -Inf & Inf days relative to cohort_start_date between 1 and Inf")))
# cohort Id
cdm$cohort4 <- requireConceptIntersect(cohort = cdm$cohort1,
cohortId = 1,
conceptSet = list(a = 1),
window = c(-Inf, Inf),
name = "cohort4")
cohortId = 1,
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
name = "cohort4")
expect_true(all(cdm$cohort4 |> dplyr::pull("subject_id") ==
c(rep(1, 6))))
expect_true(all(cdm$cohort4 |> dplyr::pull("cohort_start_date") |> sort() ==
Expand All @@ -59,10 +70,10 @@ test_that("require flag in concept", {
"Initial qualifying events")))
# censor date
cdm$cohort5 <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1),
window = c(-Inf, Inf),
censorDate = "cohort_end_date",
name = "cohort5")
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
censorDate = "cohort_end_date",
name = "cohort5")
expect_true(cdm$cohort5 |> dplyr::pull("subject_id") |> length() == 0)
expect_true(all(omopgenerics::attrition(cdm$cohort5)$reason ==
c("Initial qualifying events",
Expand All @@ -72,8 +83,8 @@ test_that("require flag in concept", {

# name
cdm$cohort1 <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1),
window = c(-Inf, Inf))
conceptSet = list(a = 1L),
window = c(-Inf, Inf))
expect_true(all(omopgenerics::attrition(cdm$cohort1)$reason ==
c("Initial qualifying events",
"Concept a between -Inf & Inf days relative to cohort_start_date between 1 and Inf",
Expand All @@ -83,8 +94,8 @@ test_that("require flag in concept", {
# empty concept
expect_message(
cdm$cohort1 <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(),
window = list(c(-Inf, Inf)))
conceptSet = list(),
window = list(c(-Inf, Inf)))
)
expect_true(all(omopgenerics::attrition(cdm$cohort1)$reason ==
c("Initial qualifying events",
Expand All @@ -94,16 +105,16 @@ test_that("require flag in concept", {

# expected errors
# only support one concept at the moment
expect_error(
requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1, b = 2),
window = c(-Inf, Inf))
)
expect_error(
requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = NULL,
window = c(-Inf, Inf))
)
expect_error(
requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1L, b = 2L),
window = c(-Inf, Inf))
)
expect_error(
requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = NULL,
window = c(-Inf, Inf))
)

PatientProfiles::mockDisconnect(cdm)
})
Expand Down Expand Up @@ -139,14 +150,14 @@ test_that("requiring absence in another cohort", {
cdm <- cdm_local |> copyCdm()

cdm$cohort3_inclusion <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1),
window = c(-Inf, Inf),
name = "cohort3_inclusion")
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
name = "cohort3_inclusion")
cdm$cohort3_exclusion <- requireConceptIntersect(cohort = cdm$cohort1,
conceptSet = list(a = 1),
window = c(-Inf, Inf),
intersections = 0,
name = "cohort3_exclusion")
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
intersections = 0,
name = "cohort3_exclusion")
in_both <- intersect(cdm$cohort3_inclusion |>
dplyr::pull("subject_id") |>
unique(),
Expand All @@ -171,7 +182,7 @@ test_that("requiring absence in another cohort", {
cdm$cohort3_exclusion_partial <- requireConceptIntersect(
cohort = cdm$cohort1,
cohortId = "cohort_1",
conceptSet = list(a = 1),
conceptSet = list(a = 1L),
window = c(-Inf, Inf),
intersections = 0,
name = "cohort3_exclusion_partial"
Expand Down Expand Up @@ -223,79 +234,79 @@ test_that("different intersection count requirements", {

# no intersections - people not in cohort2
expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(0, 0),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), as.integer(c(4,5,6,7,8,9,10)))
requireConceptIntersect(intersections = c(0, 0),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), as.integer(c(4,5,6,7,8,9,10)))


# only one intersection
expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(1, 1),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(1L))
requireConceptIntersect(intersections = c(1, 1),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(1L))

expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(1),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(1L))
requireConceptIntersect(intersections = c(1),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(1L))

# 2 intersections
expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(2, 2),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L))
requireConceptIntersect(intersections = c(2, 2),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L))

expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(2),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L))
requireConceptIntersect(intersections = c(2),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L))


# 2 or more intersections
expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(2, Inf),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L, 3L))
requireConceptIntersect(intersections = c(2, Inf),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L, 3L))

# 2 or 3 intersections
expect_identical(sort(cdm$cohort1 |>
requireConceptIntersect(intersections = c(2, 3),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L, 3L))
requireConceptIntersect(intersections = c(2, 3),
conceptSet = list("a" = 1),
window = c(-Inf, Inf),
name = "cohort1_test") |>
dplyr::pull("subject_id")), c(2L, 3L))



# expected errors
expect_error(requireConceptIntersect(cohort = cdm$cohort1,
intersections = c(-10, 10),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
intersections = c(-10, 10),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
expect_error(requireConceptIntersect(cohort = cdm$cohort1,
intersections = c(11, 10),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
intersections = c(11, 10),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
expect_error(requireConceptIntersect(cohort = cdm$cohort1,
intersections = c(Inf, Inf),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
intersections = c(Inf, Inf),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
expect_error(requireConceptIntersect(cohort = cdm$cohort1,
intersections = c(1, 2, 3),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))
intersections = c(1, 2, 3),
conceptSet = list("a" = 1),
window = c(-Inf, Inf)))

PatientProfiles::mockDisconnect(cdm)

Expand Down

0 comments on commit 0f455ab

Please sign in to comment.