Merge pull request #419 from OHDSI/validate

Use `omopgenerics` validate functions
OHDSI · Dec 23, 2024 · 0517cb5 · 0517cb5
2 parents 7c9a03e + 5e11bf3
commit 0517cb5
Show file tree

Hide file tree

Showing 35 changed files with 260 additions and 209 deletions.
diff --git a/CohortConstructor.Rproj b/CohortConstructor.Rproj
@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 779b5651-201f-45d8-a082-77eab4564366
 
 RestoreWorkspace: No
 SaveWorkspace: No

diff --git a/R/collapseCohorts.R b/R/collapseCohorts.R
@@ -18,13 +18,20 @@ collapseCohorts <- function(cohort,
                             gap = 0,
                             name = tableName(cohort)) {
   # input validation
-  cohort <- validateCohortTable(cohort, dropExtraColumns = TRUE)
+  cohort <- omopgenerics::validateCohortArgument(cohort, dropExtraColumns = TRUE)
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   omopgenerics::assertNumeric(gap, integerish = TRUE, min = 0, length = 1)
   ids <- 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]])
+  }
+
   # temp tables
   tablePrefix <- omopgenerics::tmpPrefix()
   tmpNewCohort <- paste0(omopgenerics::uniqueTableName(tablePrefix), "_1")

diff --git a/R/exitAtColumnDate.R b/R/exitAtColumnDate.R
@@ -104,11 +104,18 @@ exitAtColumnDate <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
   cohort <- omopgenerics::validateCohortArgument(cohort)
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   validateCohortColumn(dateColumns, cohort, "Date")
   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/exitAtDate.R b/R/exitAtDate.R
@@ -33,10 +33,17 @@ exitAtObservationEnd <- function(cohort,
                                  limitToCurrentPeriod = TRUE,
                                  name = tableName(cohort)) {
   # checks
-  cohort <- validateCohortTable(cohort, dropExtraColumns = TRUE)
+  cohort <- omopgenerics::validateCohortArgument(cohort, dropExtraColumns = TRUE)
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
+
+  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]])
+  }
 
   tmpTable <- omopgenerics::uniqueTableName()
   if (all(cohortId %in% settings(cohort)$cohort_definition_id)) {
@@ -153,11 +160,18 @@ exitAtDeath <- function(cohort,
                         name = tableName(cohort)) {
   # checks
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
-  cohort <- validateCohortTable(cohort, dropExtraColumns = TRUE)
+  cohort <- omopgenerics::validateCohortArgument(cohort, dropExtraColumns = TRUE)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   omopgenerics::assertLogical(requireDeath, 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]])
+  }
+
   # create new cohort
   newCohort <- cohort |>
     PatientProfiles::addDeathDate(name = name) |>

diff --git a/R/intersectCohorts.R b/R/intersectCohorts.R
@@ -42,7 +42,7 @@ intersectCohorts <- function(cohort,
   cohort <- omopgenerics::validateCohortArgument(cohort)
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   omopgenerics::assertNumeric(gap, integerish = TRUE, min = 0, length = 1)
   omopgenerics::assertLogical(returnNonOverlappingCohorts, length = 1)
   omopgenerics::assertLogical(keepOriginalCohorts, length = 1)

diff --git a/R/matchCohorts.R b/R/matchCohorts.R
@@ -52,11 +52,16 @@ matchCohorts <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   omopgenerics::assertNumeric(ratio, min = 0, length = 1)
   omopgenerics::assertLogical(matchSex, length = 1)
   omopgenerics::assertLogical(matchYearOfBirth, 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]])
+  }
 
   # table prefix
   tablePrefix <- omopgenerics::tmpPrefix()

diff --git a/R/padCohortDate.R b/R/padCohortDate.R
@@ -156,8 +156,16 @@ padCohortStart <- function(cohort,
   omopgenerics::assertCharacter(indexDate, length = 1, call = call)
   validateColumn(indexDate, cohort, call = call)
   omopgenerics::assertLogical(collapse, length = 1)
-  cohortId <- validateCohortId(cohortId, set = settings(cohort), call = call)
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
+
+  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
+    cohort <- cohort |> dplyr::compute(name = name, temporary = FALSE)
+    return(cohort)
+  }
+
   msg <- "`days` be an integerish or point to an integerish column of cohort"
   reason <- paste0("pad `", cohortDate, "` ")
   if (is.numeric(days)) {

diff --git a/R/requireCohortIntersect.R b/R/requireCohortIntersect.R
@@ -42,9 +42,16 @@ requireCohortIntersect <- function(cohort,
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
   window <- omopgenerics::validateWindowArgument(window)
-  cohortId <- validateCohortId(cohortId, settings(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
@@ -46,10 +46,17 @@ requireConceptIntersect <- function(cohort,
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
   window <- omopgenerics::validateWindowArgument(window)
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   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
@@ -35,9 +35,16 @@ requireInDateRange <- function(cohort,
   cohort <- omopgenerics::validateCohortArgument(cohort)
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(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
@@ -116,9 +121,16 @@ trimToDateRange <- function(cohort,
   validateCohortColumn(startDate, cohort, class = "Date")
   validateCohortColumn(endDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(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
@@ -41,10 +41,17 @@ requireDeathFlag <- function(cohort,
   cohort <- omopgenerics::validateCohortArgument(cohort)
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   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
@@ -244,11 +244,17 @@ demographicsFilter <- function(cohort,
   cohort <- omopgenerics::validateCohortArgument(cohort)
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(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/requireIsEntry.R b/R/requireIsEntry.R
@@ -27,7 +27,14 @@ requireIsEntry <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
+
+  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]])
+  }
 
   omopgenerics::assertNumeric(entryRange, integerish = TRUE, min = 0)
   if (length(entryRange) < 1 || length(entryRange) > 2) {
@@ -103,7 +110,6 @@ requireIsEntry <- function(cohort,
 #' @inheritParams cohortDoc
 #' @inheritParams cohortIdModifyDoc
 #' @inheritParams nameDoc
-#' @param name Name of the new cohort with the restriction.
 #'
 #' @return A cohort table in a cdm reference.
 #' @export
@@ -122,7 +128,14 @@ requireIsFirstEntry <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
+
+  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]])
+  }
 
   cohort <- cohort |>
     dplyr::group_by(.data$subject_id, .data$cohort_definition_id) |>
@@ -152,11 +165,9 @@ requireIsFirstEntry <- function(cohort,
 #' `requireIsLastEntry()` filters cohort records, keeping only the last
 #' cohort entry per person.
 #'
-#' @param cohort A cohort table in a cdm reference.
-#' @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.
-#' @param name Name of the new cohort with the restriction.
+#' @inheritParams cohortDoc
+#' @inheritParams cohortIdModifyDoc
+#' @inheritParams nameDoc
 #'
 #' @return A cohort table in a cdm reference.
 #' @export
@@ -175,7 +186,14 @@ requireIsLastEntry <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
+
+  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]])
+  }
 
   cohort <- cohort |>
     dplyr::group_by(.data$subject_id, .data$cohort_definition_id) |>

diff --git a/R/requireMinCohortCount.R b/R/requireMinCohortCount.R
@@ -32,9 +32,16 @@ requireMinCohortCount <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   minCohortCount <- validateN(minCohortCount)
 
+  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]])
+  }
+
   cohortsToDrop <- cohortCount(cohort) |>
     dplyr::filter(.data$cohort_definition_id %in% cohortId,
                   .data$number_subjects < minCohortCount) |>

diff --git a/R/requireTableIntersect.R b/R/requireTableIntersect.R
@@ -41,10 +41,17 @@ requireTableIntersect <- function(cohort,
   validateCohortColumn(indexDate, cohort, class = "Date")
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
   window <- omopgenerics::validateWindowArgument(window)
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   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/sampleCohorts.R b/R/sampleCohorts.R
@@ -29,9 +29,16 @@ sampleCohorts <- function(cohort,
   name <- omopgenerics::validateNameArgument(name, validation = "warning")
   cohort <- omopgenerics::validateCohortArgument(cohort)
   cdm <- omopgenerics::validateCdmArgument(omopgenerics::cdmReference(cohort))
-  cohortId <- validateCohortId(cohortId, settings(cohort))
+  cohortId <- omopgenerics::validateCohortIdArgument({{cohortId}}, cohort, validation = "warning")
   n <- validateN(n)
 
+  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]])
+  }
+
   cdm[[name]] <- cohort |>
     dplyr::filter(.data$cohort_definition_id %in% .env$cohortId) |>
     dplyr::group_by(.data$cohort_definition_id) |>