checks

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

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") {

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

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

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 |>

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",

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",

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

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(

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

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) |>

tests/testthat/test-requireConceptIntersect.R

@@ -235,62 +235,57 @@ 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)))
 
   # 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))
 
   # 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", {