Add in the attrition records drop when creating concept cohort

R/conceptCohort.R

@@ -193,16 +193,13 @@ conceptCohort <- function(cdm,
 
   cli::cli_inform(c("i" = "Applying cohort requirements."))
   cdm[[name]] <- fulfillCohortReqs(cdm = cdm, name = name)
-  cdm[[name]] <- omopgenerics::newCohortTable(table = cdm[[name]],
-                                              cohortAttritionRef = NULL,
-                                              .softValidation = TRUE)
 
   cli::cli_inform(c("i" = "Collapsing records."))
   cdm[[name]] <- cdm[[name]] |>
-    joinOverlap(name = name, gap = 0)
-  cdm[[name]] <- omopgenerics::newCohortTable(table = cdm[[name]],
-                                              cohortAttritionRef = NULL,
-                                              .softValidation = TRUE)
+    joinOverlap(name = name, gap = 0)  |>
+    omopgenerics::recordCohortAttrition(reason = "Collapse overlapping records")
+
+  cdm[[name]] <- omopgenerics::newCohortTable(table = cdm[[name]])
 
   cli::cli_inform(c("v" = "Cohort {.strong {name}} created."))
 
@@ -309,10 +306,6 @@ unerafiedConceptCohort <- function(cdm,
       "cohort_end_date"
     ) |>
     dplyr::mutate(cohort_end_date = dplyr::coalesce(.data$cohort_end_date, .data$cohort_start_date)) |>
-    dplyr::filter(
-      !is.na(.data$cohort_start_date),
-      .data$cohort_start_date <= .data$cohort_end_date
-    ) |>
     dplyr::compute(name = name, temporary = FALSE)
 
   omopgenerics::dropTable(cdm, name = dplyr::starts_with(workingTblNames))
@@ -324,6 +317,12 @@ fulfillCohortReqs <- function(cdm, name) {
   # 1) if start is out of observation, drop cohort entry
   # 2) if end is after observation end, set cohort end as observation end
   cdm[[name]] |>
+    dplyr::filter(
+      !is.na(.data$cohort_start_date),
+      .data$cohort_start_date <= .data$cohort_end_date
+    ) |>
+    dplyr::compute(temporary = FALSE, name = name) |>
+    omopgenerics::recordCohortAttrition(reason = "Record start <= record end") |>
     dplyr::left_join(
       cdm$observation_period |>
         dplyr::select(
@@ -350,7 +349,8 @@ fulfillCohortReqs <- function(cdm, name) {
       "cohort_start_date",
       "cohort_end_date"
     ) |>
-    dplyr::compute(temporary = FALSE, name = name)
+    dplyr::compute(temporary = FALSE, name = name) |>
+    omopgenerics::recordCohortAttrition(reason = "Record in observation")
 }
 
 

R/measurementCohort.R

@@ -126,6 +126,7 @@ measurementCohort <- function(cdm,
     dplyr::filter(tolower(.data$domain_id) %in% "measurement") |>
     dplyr::compute(name = tmpCodelist, temporary = FALSE)
 
+  cli::cli_inform(c("i" = "Subsetting measurement table."))
   cohort <- cdm$measurement |>
     dplyr::select(
       "subject_id" = "person_id",
@@ -140,9 +141,29 @@ measurementCohort <- function(cdm,
       cohortCodelist |> dplyr::select("concept_id", "cohort_definition_id"),
       by = "concept_id"
     ) |>
-    dplyr::filter(!is.na(.data$cohort_start_date)) |>
     dplyr::compute(name = name, temporary = FALSE)
 
+  if (!is.null(valueAsConcept) || !is.null(valueAsNumber)) {
+    cli::cli_inform(c("i" = "Applying measurement requirements."))
+    filterExpr <- getFilterExpression(valueAsConcept, valueAsNumber)
+    cohort <- cohort |>
+      dplyr::filter(!!!filterExpr) |>
+      dplyr::compute(name = name, temporary = FALSE)
+
+    if (cohort |> dplyr::tally() |> dplyr::pull("n") == 0) {
+      cli::cli_warn(
+        "There are no subjects with the specified value_as_concept_id or value_as_number."
+      )
+    }
+  }
+
+  cohort <- cohort |>
+    omopgenerics::newCohortTable(
+      cohortSetRef = cohortSet,
+      cohortCodelistRef = cohortCodelist |> dplyr::collect(),
+      .softValidation = TRUE
+    )
+
   if (cohort |> dplyr::tally() |> dplyr::pull("n") == 0) {
     cli::cli_inform(c("i" = "No table could be subsetted, returning empty cohort."))
     cdm <- omopgenerics::emptyCohortTable(cdm = cdm, name = name)
@@ -153,61 +174,47 @@ measurementCohort <- function(cdm,
                     "cohort_end_date") |>
       omopgenerics::newCohortTable(
         cohortSetRef = cohortSet,
-        cohortAttritionRef = NULL,
+        cohortAttritionRef = attrition(cohort),
         cohortCodelistRef = cohortCodelist |> dplyr::collect()
       )
     return(cdm[[name]])
   }
 
   cli::cli_inform(c("i" = "Getting records in observation."))
   cohort <- cohort |>
-    PatientProfiles::addDemographics(
-      age = FALSE,
-      sex = FALSE,
-      priorObservationType = "date",
-      futureObservationType = "date",
-      name = name
+    dplyr::filter(!is.na(.data$cohort_start_date)) |>
+    dplyr::compute(name = name, temporary = FALSE) |>
+    omopgenerics::recordCohortAttrition(reason = "Not missing record date") |>
+    dplyr::left_join(
+      cdm$observation_period |>
+        dplyr::select(
+          "person_id",
+          "observation_period_start_date",
+          "observation_period_end_date"
+        ),
+      by = c("subject_id" = "person_id")
     ) |>
     dplyr::filter(
-      .data$prior_observation <= .data$cohort_start_date,
-      .data$future_observation >= .data$cohort_end_date
+      .data$observation_period_start_date <= .data$cohort_start_date,
+      .data$observation_period_end_date >= .data$cohort_end_date
     ) |>
-    dplyr::select(-"prior_observation", -"future_observation") |>
-    dplyr::compute(name = name, temporary = FALSE)
-
-
-  if (!is.null(valueAsConcept) || !is.null(valueAsNumber)) {
-    cli::cli_inform(c("i" = "Applying measurement requirements."))
-    filterExpr <- getFilterExpression(valueAsConcept, valueAsNumber)
-    cohort <- cohort |>
-      dplyr::filter(!!!filterExpr) |>
-      dplyr::compute(name = name, temporary = FALSE)
-
-    if (cohort |> dplyr::tally() |> dplyr::pull("n") == 0) {
-      cli::cli_warn(
-        "There are no subjects with the specified value_as_concept_id or value_as_number."
-      )
-    }
-
-  }
+    dplyr::select(-"observation_period_start_date", -"observation_period_end_date") |>
+    dplyr::compute(name = name, temporary = FALSE) |>
+    omopgenerics::recordCohortAttrition(reason = "Record in observation")
 
   cohort <- cohort |>
     dplyr::select("cohort_definition_id",
                   "subject_id",
                   "cohort_start_date",
                   "cohort_end_date") |>
     dplyr::distinct() |>
-    dplyr::compute(name = name, temporary = FALSE)
+    dplyr::compute(name = name, temporary = FALSE) |>
+    omopgenerics::recordCohortAttrition(reason = "Distinct measurement records")
 
   cli::cli_inform(c("i" = "Creating cohort attributes."))
 
   cohort <- cohort |>
-    omopgenerics::newCohortTable(
-      cohortSetRef = cohortSet,
-      cohortAttritionRef = NULL,
-      cohortCodelistRef = cohortCodelist |> dplyr::collect(),
-      .softValidation = TRUE
-    )
+    omopgenerics::newCohortTable(.softValidation = TRUE)
 
   cli::cli_inform(c("v" = "Cohort {.strong {name}} created."))
 

R/validateFunctions.R

@@ -184,7 +184,7 @@ validateStrata <- function(strata, cohort) {
 validateValueAsNumber <- function(valueAsNumber) {
   omopgenerics::assertList(valueAsNumber,
     named = TRUE,
-    class = "numeric",
+    class = c("integer", "numeric"),
     null = TRUE
   )
   for (i in seq_along(valueAsNumber)) {