add visR attrition diagram

DESCRIPTION

@@ -57,7 +57,8 @@ Suggests:
     lubridate,
     tibble,
     testthat (>= 3.0.0),
-    pool
+    pool,
+    visR
 Enhances:
     CirceR,
     Capr

NAMESPACE

@@ -11,6 +11,7 @@ S3method(cohortSet,GeneratedCohortSet)
 S3method(collect,cdm_reference)
 S3method(dbplyr_edition,BigQueryConnection)
 S3method(print,cdm_reference)
+S3method(visr,omop_attrition)
 export("%>%")
 export(appendPermanent)
 export(append_permanent)
@@ -124,4 +125,5 @@ importFrom(tidyselect,matches)
 importFrom(tidyselect,starts_with)
 importFrom(utils,download.file)
 importFrom(utils,head)
+importFrom(visR,visr)
 importMethodsFrom(DBI,dbConnect)

R/generateCohortSet.R

@@ -813,9 +813,11 @@ cohort_attrition <- cohortAttrition
 #' @export
 cohortAttrition.GeneratedCohortSet <- function(x) {
   if (is.null(attr(x, "cohort_attrition"))) {
-    NULL
+    return(invisible(NULL))
   } else {
-    dplyr::collect(attr(x, "cohort_attrition"))
+    a <- dplyr::collect(attr(x, "cohort_attrition"))
+    class(a) <- c("omop_attrition", "attrition", class(a))
+    return(a)
   }
 }
 

R/visR.R

@@ -0,0 +1,43 @@
+
+#' Create an attrition diagram from a generated cohort set
+#'
+#' @param x A GeneratedCohortSet object
+#' @param ... Not used
+#'
+#' `r lifecycle::badge("experimental")`
+#'
+#' @return No return value. This function will create one attrition plot for each generated cohort.
+#' @export
+#' @importFrom visR visr
+#'
+#' @examples
+#' \dontrun{
+#' library(CDMConnector)
+#' library(dplyr)
+#'
+#' con <- DBI::dbConnect(duckdb::duckdb(), eunomia_dir())
+#' cdm <- cdm_from_con(con, "main", "main")
+#' cohort_set <- read_cohort_set(system.file("cohorts2", package = "CDMConnector"))
+#' cdm <- generate_cohort_set(cdm, cohort_set, name = "cohort", overwrite = T)
+#'
+#' cohort_attrition(cdm$cohort) %>%
+#'   dplyr::filter(cohort_definition_id == 3) %>%
+#'   visR::visr()
+#'
+#' DBI::dbDisconnect(con, shutdown = TRUE)
+#' }
+#'
+visr.omop_attrition <- function(x, ...) {
+  if (!rlang::is_installed("visR")) cli::cli_abort("Please install the visR package.")
+
+  ids <- unique(x$cohort_definition_id)
+  if (length(ids) > 1) {
+    cli::cli_abort("Cannot create attrition diagram because your cohort set has more than one cohort ID ({paste(ids, collapse = ', ')}). \nFirst make sure there is only one cohort_definition_id in the cohort set.")
+  }
+  checkmate::assertIntegerish(ids, len = 1, lower = 1, any.missing = FALSE)
+
+  x <- x %>%
+    dplyr::select(Criteria = reason, `Remaining N` = number_subjects)
+
+  NextMethod(x)
+}

tests/testthat/test-visR.R

@@ -0,0 +1,23 @@
+
+test_that("visR attrition diagram works", {
+  con <- DBI::dbConnect(duckdb::duckdb(), eunomia_dir())
+  cdm <- cdm_from_con(con, "main", "main")
+  cohort_set <- read_cohort_set(system.file("cohorts2", package = "CDMConnector"))
+  cdm <- generate_cohort_set(cdm, cohort_set, name = "cohort", overwrite = T)
+
+  expect_error({
+    cohort_attrition(cdm$cohort) %>%
+      visR::visr()
+  })
+
+  expect_no_error({
+    cohort_attrition(cdm$cohort) %>%
+      dplyr::filter(cohort_definition_id == 3) %>%
+      visR::visr()
+  })
+
+  DBI::dbDisconnect(con, shutdown = TRUE)
+})
+
+
+