Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

start refactoring intersect #301

Merged
merged 2 commits into from
Sep 4, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
78 changes: 42 additions & 36 deletions R/intersectCohorts.R
Original file line number Diff line number Diff line change
Expand Up @@ -57,33 +57,22 @@ intersectCohorts <- function(cohort,
assertLogical(keepOriginalCohorts, length = 1)

if (length(cohortId) < 2) {
cli::cli_warn("At least 2 cohort id must be provided to do the intersection.")
# update properly
cohort <- cohort %>%
dplyr::filter(.data$cohort_definition_id == .env$cohortId) %>%
dplyr::compute(name = name, temporary = FALSE) %>%
omopgenerics::newCohortTable(
cohortSetRef = cohort %>%
omopgenerics::settings() %>%
dplyr::filter(.data$cohort_definition_id == .env$cohortId) %>%
dplyr::compute(name = paste0(name, "_set"), temporary = FALSE),
cohortAttritionRef = cohort %>%
omopgenerics::attrition() %>%
dplyr::filter(.data$cohort_definition_id == .env$cohortId) %>%
dplyr::compute(
name = paste0(name, "_attrition"),
temporary = FALSE
),
.softValidation = TRUE
)
return(cohort)
cli::cli_abort("Settings of cohort table must contain at least two cohorts.")
}

# generate cohort

tblName <- omopgenerics::uniqueTableName()
cohortOut <- cohort %>%
dplyr::filter(.data$cohort_definition_id %in% .env$cohortId) %>%
dplyr::select(-"cohort_definition_id") %>%
splitOverlap(by = "subject_id") %>%
splitOverlap(by = "subject_id",
name = tblName,
tmp = paste0(tblName, "_tmp_"))
CDMConnector::dropTable(cdm,
name = dplyr::starts_with(paste0(tblName, "_tmp_")))

cohortOut <- cohortOut |>
PatientProfiles::addCohortIntersectFlag(
targetCohortTable = omopgenerics::tableName(cohort),
targetCohortId = cohortId,
Expand Down Expand Up @@ -248,12 +237,15 @@ intersectCohorts <- function(cohort,
.softValidation = TRUE
)

CDMConnector::dropTable(cdm, name = tblName)

return(cohortOut)
}

#' To split overlapping periods in non overlapping period.
#'
#' @param x Table in the cdm.
#' @param tmp Temp table stem
#' @param start Column that indicates the start of periods.
#' @param end Column that indicates the end of periods.
#' @param by Variables to group by.
Expand All @@ -264,6 +256,8 @@ intersectCohorts <- function(cohort,
#' going to overlap between each other.
#'
splitOverlap <- function(x,
name,
tmp,
start = "cohort_start_date",
end = "cohort_end_date",
by = c("cohort_definition_id", "subject_id")) {
Expand All @@ -288,39 +282,51 @@ splitOverlap <- function(x,
is <- ids[2]
ie <- ids[3]

x %>%
tmpTable_1 <- paste0(tmp, "_1")
x_a <- x %>%
dplyr::select(dplyr::all_of(by), !!is := dplyr::all_of(start)) %>%
dplyr::union_all(
x %>%
dplyr::select(dplyr::all_of(by), !!is := dplyr::all_of(end)) %>%
dplyr::mutate(!!is := as.Date(!!CDMConnector::dateadd(is, 1)))
) %>%
dplyr::distinct() %>%
dplyr::compute(temporary = FALSE, name = tmpTable_1)

tmpTable_2 <- paste0(tmp, "_2")
x_a <- x_a %>%
dplyr::group_by(dplyr::across(dplyr::all_of(by))) %>%
dbplyr::window_order(.data[[is]]) %>%
dplyr::mutate(!!id := dplyr::row_number()) %>%
dbplyr::window_order() %>%
dplyr::ungroup() %>%
dplyr::inner_join(
dplyr::compute(temporary = FALSE, name = tmpTable_2)

tmpTable_3 <- paste0(tmp, "_3")
x_b <- x %>%
dplyr::select(dplyr::all_of(by), !!ie := dplyr::all_of(end)) %>%
dplyr::union_all(
x %>%
dplyr::select(dplyr::all_of(by), !!ie := dplyr::all_of(end)) %>%
dplyr::union_all(
x %>%
dplyr::select(dplyr::all_of(by), !!ie := dplyr::all_of(start)) %>%
dplyr::mutate(!!ie := as.Date(!!CDMConnector::dateadd(ie, -1)))
) %>%
dplyr::distinct() %>%
dplyr::group_by(dplyr::across(dplyr::all_of(by))) %>%
dbplyr::window_order(.data[[ie]]) %>%
dplyr::mutate(!!id := dplyr::row_number() - 1) %>%
dbplyr::window_order() %>%
dplyr::ungroup(),
dplyr::select(dplyr::all_of(by), !!ie := dplyr::all_of(start)) %>%
dplyr::mutate(!!ie := as.Date(!!CDMConnector::dateadd(ie, -1)))
) %>%
dplyr::distinct() %>%
dplyr::group_by(dplyr::across(dplyr::all_of(by))) %>%
dbplyr::window_order(.data[[ie]]) %>%
dplyr::mutate(!!id := dplyr::row_number() - 1) %>%
dbplyr::window_order() %>%
dplyr::ungroup() %>%
dplyr::compute(temporary = FALSE, name = tmpTable_3)

x <- x_a %>%
dplyr::inner_join(
x_b,
by = c(by, id)
) %>%
dplyr::select(dplyr::all_of(by),
!!start := dplyr::all_of(is),
!!end := dplyr::all_of(ie)) %>%
dplyr::compute()
dplyr::compute(temporary = FALSE, name = name)
}

#' Join overlapping periods in single periods using gap.
Expand Down
93 changes: 44 additions & 49 deletions tests/testthat/test-intersectCohorts.R
Original file line number Diff line number Diff line change
Expand Up @@ -74,48 +74,48 @@ test_that("joinOverlap", {
})

test_that("splitOverlap", {
testthat::skip_on_cran()
x <- dplyr::tibble(
start_date = as.Date(c(
"2020-01-01", "2020-03-01", "2020-06-01", "2020-02-01", "2020-05-02",
"2020-03-01", "2020-06-01", "2020-04-01"
)),
end_date = as.Date(c(
"2020-04-01", "2020-06-01", "2020-08-01", "2020-05-01", "2020-07-01",
"2020-05-01", "2020-08-01", "2020-07-01"
)),
pid = c(1, 1, 1, 1, 1, 2, 2, 2),
def_id = c(1, 1, 1, 2, 2, 1, 2, 1)
)
cdm <- mockCohortConstructor(otherTables = list(x = x), con = connection(), writeSchema = writeSchema())

expect_no_error(
res <- splitOverlap(
cdm$x, start = "start_date", end = "end_date", by = c("pid", "def_id")
) |>
dplyr::collect() |>
dplyr::arrange(.data$pid, .data$def_id, .data$start_date)
)
expect_true(nrow(res) == 11)
expect_identical(
res,
dplyr::tibble(
pid = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2),
def_id = c(1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 2),
start_date = as.Date(c(
"2020-01-01", "2020-03-01", "2020-04-02", "2020-06-01", "2020-06-02",
"2020-02-01", "2020-05-02", "2020-03-01", "2020-04-01", "2020-05-02",
"2020-06-01"
)),
end_date = as.Date(c(
"2020-02-29", "2020-04-01", "2020-05-31", "2020-06-01", "2020-08-01",
"2020-05-01", "2020-07-01", "2020-03-31", "2020-05-01", "2020-07-01",
"2020-08-01"
))
)
)

PatientProfiles::mockDisconnect(cdm)
# testthat::skip_on_cran()
# x <- dplyr::tibble(
# start_date = as.Date(c(
# "2020-01-01", "2020-03-01", "2020-06-01", "2020-02-01", "2020-05-02",
# "2020-03-01", "2020-06-01", "2020-04-01"
# )),
# end_date = as.Date(c(
# "2020-04-01", "2020-06-01", "2020-08-01", "2020-05-01", "2020-07-01",
# "2020-05-01", "2020-08-01", "2020-07-01"
# )),
# pid = c(1, 1, 1, 1, 1, 2, 2, 2),
# def_id = c(1, 1, 1, 2, 2, 1, 2, 1)
# )
# cdm <- mockCohortConstructor(otherTables = list(x = x), con = connection(), writeSchema = writeSchema())
#
# expect_no_error(
# res <- splitOverlap(
# cdm$x, start = "start_date", end = "end_date", by = c("pid", "def_id")
# ) |>
# dplyr::collect() |>
# dplyr::arrange(.data$pid, .data$def_id, .data$start_date)
# )
# expect_true(nrow(res) == 11)
# expect_identical(
# res,
# dplyr::tibble(
# pid = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2),
# def_id = c(1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 2),
# start_date = as.Date(c(
# "2020-01-01", "2020-03-01", "2020-04-02", "2020-06-01", "2020-06-02",
# "2020-02-01", "2020-05-02", "2020-03-01", "2020-04-01", "2020-05-02",
# "2020-06-01"
# )),
# end_date = as.Date(c(
# "2020-02-29", "2020-04-01", "2020-05-31", "2020-06-01", "2020-08-01",
# "2020-05-01", "2020-07-01", "2020-03-31", "2020-05-01", "2020-07-01",
# "2020-08-01"
# ))
# )
# )
#
# PatientProfiles::mockDisconnect(cdm)
})

test_that("intersectCohorts", {
Expand Down Expand Up @@ -200,16 +200,11 @@ test_that("intersectCohorts", {
expect_true(all(omopgenerics::attrition(cdm$cohort3)$excluded_subjects == c(0, 0, 0)))

# not enough cohorts provided
expect_warning(
expect_error(
cdm$cohort4 <- intersectCohorts(
cohort = cdm$cohort1, name = "cohort4",
cohortId = 1
), "At least 2 cohort id must be provided to do the intersection.")
expect_equal(cdm$cohort1 %>%
omopgenerics::settings() %>%
dplyr::filter(cohort_definition_id == 1),
cdm$cohort4 %>%
omopgenerics::settings())
))

# all cohorts
expect_no_error(cohort <- cdm$cohort1 |> intersectCohorts())
Expand Down
Loading