From 11457e4c4b9b63739f87f570c6c93180b4b744c9 Mon Sep 17 00:00:00 2001 From: nmercadeb Date: Fri, 20 Dec 2024 12:54:41 +0100 Subject: [PATCH] checks --- CohortConstructor.Rproj | 4 --- R/exitAtColumnDate.R | 7 +++++ R/requireCohortIntersect.R | 7 +++++ R/requireConceptIntersect.R | 7 +++++ R/requireDateRange.R | 26 ++++++++++++++----- R/requireDeathFlag.R | 7 +++++ R/requireDemographics.R | 8 +++++- R/requireTableIntersect.R | 7 +++++ R/stratifyCohorts.R | 6 +++++ R/trimDemographics.R | 7 +++++ R/yearCohorts.R | 6 +++++ man/requireIsFirstEntry.Rd | 2 +- man/requireIsLastEntry.Rd | 5 ++-- man/trimToDateRange.Rd | 9 ++++--- tests/testthat/test-requireConceptIntersect.R | 20 +++++--------- 15 files changed, 96 insertions(+), 32 deletions(-) diff --git a/CohortConstructor.Rproj b/CohortConstructor.Rproj index 4e041251..9fce96d9 100644 --- a/CohortConstructor.Rproj +++ b/CohortConstructor.Rproj @@ -1,9 +1,5 @@ Version: 1.0 -<<<<<<< HEAD ProjectId: 779b5651-201f-45d8-a082-77eab4564366 -======= -ProjectId: 27e959ec-87b2-4ff1-ac1d-3ea886296a0d ->>>>>>> main RestoreWorkspace: No SaveWorkspace: No diff --git a/R/exitAtColumnDate.R b/R/exitAtColumnDate.R index 1d4d8876..37646773 100644 --- a/R/exitAtColumnDate.R +++ b/R/exitAtColumnDate.R @@ -109,6 +109,13 @@ exitAtColumnDate <- function(cohort, omopgenerics::assertLogical(returnReason, length = 1) ids <- omopgenerics::settings(cohort)$cohort_definition_id + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + if (order == "first") { atDateFunction <- rlang::expr(min(.data$new_date_0123456789, na.rm = TRUE)) # NA always removed in SQL } else if (order == "last") { diff --git a/R/requireCohortIntersect.R b/R/requireCohortIntersect.R index 823d829d..1b3140c7 100644 --- a/R/requireCohortIntersect.R +++ b/R/requireCohortIntersect.R @@ -45,6 +45,13 @@ requireCohortIntersect <- function(cohort, cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning") intersections <- validateIntersections(intersections) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + lower_limit <- as.integer(intersections[[1]]) upper_limit <- intersections[[2]] upper_limit[is.infinite(upper_limit)] <- 999999L diff --git a/R/requireConceptIntersect.R b/R/requireConceptIntersect.R index df6a3eea..cd78e6f1 100644 --- a/R/requireConceptIntersect.R +++ b/R/requireConceptIntersect.R @@ -50,6 +50,13 @@ requireConceptIntersect <- function(cohort, intersections <- validateIntersections(intersections) conceptSet <- omopgenerics::validateConceptSetArgument(conceptSet, cdm) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + lower_limit <- as.integer(intersections[[1]]) upper_limit <- intersections[[2]] upper_limit[is.infinite(upper_limit)] <- 999999L diff --git a/R/requireDateRange.R b/R/requireDateRange.R index ead53ddd..a6896b3b 100644 --- a/R/requireDateRange.R +++ b/R/requireDateRange.R @@ -38,6 +38,13 @@ requireInDateRange <- function(cohort, cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning") dateRange <- validateDateRange(dateRange) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + # requirement if (!is.na(dateRange[1])) { cohort <- cohort |> @@ -78,15 +85,13 @@ requireInDateRange <- function(cohort, #' `trimToDateRange()` resets the cohort start and end date based on the #' specified date range. #' -#' @param cohort A cohort table in a cdm reference. -#' @param dateRange A window of time during which the index date must have -#' been observed. -#' @param cohortId IDs of the cohorts to modify. If NULL, all cohorts will be -#' used; otherwise, only the specified cohorts will be modified, and the -#' rest will remain unchanged. +#' @inheritParams cohortDoc +#' @inheritParams cohortIdModifyDoc +#' @inheritParams nameDoc +#' @param dateRange A window of time during which the start and end date must +#' have been observed. #' @param startDate Variable with earliest date. #' @param endDate Variable with latest date. -#' @param name Name of the new cohort with the restriction. #' #' @return The cohort table with record timings updated to only be within the #' date range. Any records with all time outside of the range will have @@ -119,6 +124,13 @@ trimToDateRange <- function(cohort, cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning") dateRange <- validateDateRange(dateRange) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + # trim start if (!is.na(dateRange[1])) { cohort <- cohort |> diff --git a/R/requireDeathFlag.R b/R/requireDeathFlag.R index d617dd2d..6090abfd 100644 --- a/R/requireDeathFlag.R +++ b/R/requireDeathFlag.R @@ -45,6 +45,13 @@ requireDeathFlag <- function(cohort, window <- omopgenerics::validateWindowArgument(window) omopgenerics::assertLogical(negate, length = 1) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + cols <- unique( c( "cohort_definition_id", diff --git a/R/requireDemographics.R b/R/requireDemographics.R index 18e52a8a..44dcfeb7 100644 --- a/R/requireDemographics.R +++ b/R/requireDemographics.R @@ -246,9 +246,15 @@ demographicsFilter <- function(cohort, cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort)) cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning") ageRange <- validateDemographicRequirements(ageRange, sex, minPriorObservation, minFutureObservation) - ids <- omopgenerics::settings(cohort)$cohort_definition_id + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + # output cohort attributes ---- reqCols <- c("age_range", "sex", diff --git a/R/requireTableIntersect.R b/R/requireTableIntersect.R index ab317759..4aafe830 100644 --- a/R/requireTableIntersect.R +++ b/R/requireTableIntersect.R @@ -45,6 +45,13 @@ requireTableIntersect <- function(cohort, intersections <- validateIntersections(intersections) omopgenerics::assertCharacter(tableName) + if (length(cohortId) == 0) { + cli::cli_inform("Returning entry cohort as `cohortId` is not valid.") + # return entry cohort as cohortId is used to modify not subset + cdm[[name]] <- cohort |> dplyr::compute(name = name, temporary = FALSE) + return(cdm[[name]]) + } + lower_limit <- as.integer(intersections[[1]]) upper_limit <- intersections[[2]] upper_limit[is.infinite(upper_limit)] <- 999999L diff --git a/R/stratifyCohorts.R b/R/stratifyCohorts.R index db8d015a..fc32e37d 100644 --- a/R/stratifyCohorts.R +++ b/R/stratifyCohorts.R @@ -47,6 +47,12 @@ stratifyCohorts <- function(cohort, strata <- validateStrata(strata, cohort) omopgenerics::assertLogical(removeStrata, length = 1) + if (length(cohortId) == 0) { + cli::cli_inform("Returning empty cohort as `cohortId` is not valid.") + cdm <- omopgenerics::emptyCohortTable(cdm = cdm, name = name) + return(cdm[[name]]) + } + if (length(strata) == 0 || sum(cohortCount(cohort)$number_records) == 0) { return(subsetCohorts( diff --git a/R/trimDemographics.R b/R/trimDemographics.R index c5221717..c452f106 100644 --- a/R/trimDemographics.R +++ b/R/trimDemographics.R @@ -5,6 +5,7 @@ #' specified demographic criteria is satisfied. #' #' @inheritParams requireDemographics +#' @inheritParams cohortIdSubsetDoc #' #' @return The cohort table with only records for individuals satisfying the #' demographic requirements @@ -39,6 +40,12 @@ trimDemographics <- function(cohort, null = TRUE ) + if (length(cohortId) == 0) { + cli::cli_inform("Returning empty cohort as `cohortId` is not valid.") + cdm <- omopgenerics::emptyCohortTable(cdm = cdm, name = name) + return(cdm[[name]]) + } + ids <- settings(cohort)$cohort_definition_id # replace age Inf to avoid potential sql issues diff --git a/R/yearCohorts.R b/R/yearCohorts.R index f8d04e48..3fb96acd 100644 --- a/R/yearCohorts.R +++ b/R/yearCohorts.R @@ -32,6 +32,12 @@ yearCohorts <- function(cohort, cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning") omopgenerics::assertNumeric(years, integerish = TRUE) + if (length(cohortId) == 0) { + cli::cli_inform("Returning empty cohort as `cohortId` is not valid.") + cdm <- omopgenerics::emptyCohortTable(cdm = cdm, name = name) + return(cdm[[name]]) + } + if (length(years) == 0) { cohort <- cohort |> dplyr::compute(name = name, temporary = FALSE) |> diff --git a/man/requireIsFirstEntry.Rd b/man/requireIsFirstEntry.Rd index b6f3b1bc..dc653e71 100644 --- a/man/requireIsFirstEntry.Rd +++ b/man/requireIsFirstEntry.Rd @@ -14,7 +14,7 @@ requireIsFirstEntry(cohort, cohortId = NULL, name = tableName(cohort)) used; otherwise, only the specified cohorts will be modified, and the rest will remain unchanged.} -\item{name}{Name of the new cohort with the restriction.} +\item{name}{Name of the new cohort table created in the cdm object.} } \value{ A cohort table in a cdm reference. diff --git a/man/requireIsLastEntry.Rd b/man/requireIsLastEntry.Rd index f22205bd..f219f136 100644 --- a/man/requireIsLastEntry.Rd +++ b/man/requireIsLastEntry.Rd @@ -9,11 +9,12 @@ requireIsLastEntry(cohort, cohortId = NULL, name = tableName(cohort)) \arguments{ \item{cohort}{A cohort table in a cdm reference.} -\item{cohortId}{IDs of the cohorts to modify. If NULL, all cohorts will be +\item{cohortId}{Vector identifying which cohorts to modify +(cohort_definition_id or cohort_name). If NULL, all cohorts will be used; otherwise, only the specified cohorts will be modified, and the rest will remain unchanged.} -\item{name}{Name of the new cohort with the restriction.} +\item{name}{Name of the new cohort table created in the cdm object.} } \value{ A cohort table in a cdm reference. diff --git a/man/trimToDateRange.Rd b/man/trimToDateRange.Rd index b910080b..bb2ad969 100644 --- a/man/trimToDateRange.Rd +++ b/man/trimToDateRange.Rd @@ -16,10 +16,11 @@ trimToDateRange( \arguments{ \item{cohort}{A cohort table in a cdm reference.} -\item{dateRange}{A window of time during which the index date must have -been observed.} +\item{dateRange}{A window of time during which the start and end date must +have been observed.} -\item{cohortId}{IDs of the cohorts to modify. If NULL, all cohorts will be +\item{cohortId}{Vector identifying which cohorts to modify +(cohort_definition_id or cohort_name). If NULL, all cohorts will be used; otherwise, only the specified cohorts will be modified, and the rest will remain unchanged.} @@ -27,7 +28,7 @@ rest will remain unchanged.} \item{endDate}{Variable with latest date.} -\item{name}{Name of the new cohort with the restriction.} +\item{name}{Name of the new cohort table created in the cdm object.} } \value{ The cohort table with record timings updated to only be within the diff --git a/tests/testthat/test-requireConceptIntersect.R b/tests/testthat/test-requireConceptIntersect.R index ca81cebe..dc8b11ee 100644 --- a/tests/testthat/test-requireConceptIntersect.R +++ b/tests/testthat/test-requireConceptIntersect.R @@ -235,7 +235,7 @@ 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), + conceptSet = list("a" = 1L), window = c(-Inf, Inf), name = "cohort1_test") |> dplyr::pull("subject_id")), as.integer(c(4,5,6,7,8,9,10))) @@ -243,14 +243,14 @@ test_that("different intersection count requirements", { # only one intersection expect_identical(sort(cdm$cohort1 |> requireConceptIntersect(intersections = c(1, 1), - conceptSet = list("a" = 1), + conceptSet = list("a" = 1L), 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), + conceptSet = list("a" = 1L), window = c(-Inf, Inf), name = "cohort1_test") |> dplyr::pull("subject_id")), c(1L)) @@ -258,39 +258,34 @@ test_that("different intersection count requirements", { # 2 intersections expect_identical(sort(cdm$cohort1 |> requireConceptIntersect(intersections = c(2, 2), - conceptSet = list("a" = 1), + conceptSet = list("a" = 1L), 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), + conceptSet = list("a" = 1L), 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), + conceptSet = list("a" = 1L), 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), + requireConceptIntersect(intersections = c(2L, 3L), 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), @@ -310,7 +305,6 @@ test_that("different intersection count requirements", { window = c(-Inf, Inf))) PatientProfiles::mockDisconnect(cdm) - }) test_that("test indexes - postgres", {