cohort_overlap

.gitignore

@@ -4,3 +4,4 @@
 .httr-oauth
 .DS_Store
 inst/doc
+.Rhistory

DESCRIPTION

@@ -29,7 +29,8 @@ Imports:
     omopgenerics (>= 0.0.2),
     PatientProfiles,
     rlang,
-    tidyr
+    tidyr,
+    utils
 Suggests: 
     DBI,
     DrugUtilisation,

NAMESPACE

@@ -17,6 +17,7 @@ export(requireSex)
 export(restrictToFirstEntry)
 export(settings)
 export(splitOverlap)
+export(summariseCohortOverlap)
 export(trimToDateRange)
 importFrom(magrittr,"%>%")
 importFrom(omopgenerics,attrition)
@@ -26,3 +27,4 @@ importFrom(omopgenerics,settings)
 importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(rlang,.env)
+importFrom(utils,data)

R/CohortConstructor-package.R

@@ -6,5 +6,6 @@
 #' @importFrom rlang .data
 #' @importFrom rlang .env
 #' @importFrom rlang :=
+#' @importFrom utils data
 ## usethis namespace: end
 NULL

R/summariseCohortOverlap.R

@@ -0,0 +1,81 @@
+#' Summarise cohort overlap
+#'
+#' @param cohort  A cohort table in a cdm reference
+#' @param restrictToFirstEntry If TRUE only an individual's first entry per
+#' cohort will be considered. If FALSE all entries per individual will be
+#' considered
+#' @param timing Summary statistics for timing. If NULL, timings between cohort
+#' entries will not be considered
+#'
+#' @return A summarised result
+#' @export
+#'
+#' @examples
+summariseCohortOverlap <- function(cohort,
+                          restrictToFirstEntry = TRUE,
+                          timing = c("min", "q25",
+                                     "median","q75",
+                                     "max")){
+
+  # validate inputs
+
+
+  # add cohort names
+  cdm <- omopgenerics::cdmReference(cohort)
+  name <- omopgenerics:::getTableName(cohort) # change to tableName when og is released
+
+  cdm[[name]] <- PatientProfiles::addCohortName(cdm[[name]])
+
+  if(isTRUE(restrictToFirstEntry)){
+    cdm[[name]] <- cdm[[name]] %>%
+      restrictToFirstEntry()
+  }
+
+  # should we use addCohortIntersectDate instead to avoid potentially large number of rows?
+  cdm[[name]] <- cdm[[name]] %>%
+    dplyr::inner_join(cdm[[name]],
+               by = "subject_id") %>%
+    dplyr::rename("cohort_start_date" = "cohort_start_date.x",
+                  "cohort_end_date" = "cohort_end_date.x",
+           "cohort_name" = "cohort_name.x",
+           "cohort_definition_id" = "cohort_definition_id.x",
+           "cohort_start_date_comparator" = "cohort_start_date.y",
+           "cohort_end_date_comparator" = "cohort_end_date.y",
+           "cohort_name_comparator" = "cohort_name.y",
+           "cohort_definition_id_comparator" = "cohort_definition_id.y") %>%
+    dplyr::mutate(comparison = as.character(paste0(as.character(.data$cohort_name),
+                                                   as.character(" &&& "),
+                                                   as.character(.data$cohort_name_comparator))))
+
+  name_overlap <- paste0(omopgenerics::uniqueTableName(), "_", name, "_overlap")
+
+  cdm[[name_overlap]] <- cdm[[name]] %>%
+    dplyr::compute(temporary = FALSE,
+                   name = name_overlap) %>%
+    omopgenerics::newCohortTable(.softValidation = TRUE)
+
+  if(is.null(timing)){
+    cohort_timings <- cdm[[name_overlap]] %>%
+      PatientProfiles::summariseCharacteristics(
+        strata = list("comparison")) %>% # can we only get number subject and records?
+      dplyr::filter(.data$variable_name %in% c("Number subjects",
+                                         "Number records")) %>%
+      dplyr::mutate(result_type = "cohort_overlap")
+
+    return(cohort_timings)
+
+  }
+
+  cohort_timings <- cdm[[name_overlap]]  %>%
+      dplyr::mutate(diff_days = !!CDMConnector::datediff("cohort_start_date",
+                                                         "cohort_start_date_comparator",
+                                                         interval = "day")) %>%
+      dplyr::collect() %>%
+      PatientProfiles::summariseResult(group=list("comparison"),
+                                       variables = list(diff_days = "diff_days"),
+                                       functions = list(diff_days = timing))%>%
+      dplyr::mutate(result_type = "cohort_overlap")
+
+    cohort_timings
+
+}

tests/testthat/test-summariseCohortOverlap.R

@@ -0,0 +1,41 @@
+test_that("expected output", {
+  cdm <- DrugUtilisation::generateConceptCohortSet(
+    cdm = DrugUtilisation::mockDrugUtilisation(numberIndividuals = 200),
+    conceptSet = list(c_1 = 317009, c_2 = 432526, c_3 = 4141052),
+    name = "cohort",
+    end  = "observation_period_end_date"
+  )
+
+ overlap1 <- summariseCohortOverlap(cdm$cohort,
+                                   restrictToFirstEntry = TRUE,
+                                   timing = c("min", "q25",
+                                              "median","q75",
+                                              "max"))
+ expect_equal(colnames(omopgenerics::emptySummarisedResult()),
+              colnames(overlap1))
+
+ overlap2 <- summariseCohortOverlap(cdm$cohort,
+                                   restrictToFirstEntry = FALSE,
+                                   timing = c("min", "q25",
+                                              "median","q75",
+                                              "max"))
+ expect_equal(colnames(omopgenerics::emptySummarisedResult()),
+              colnames(overlap2))
+
+
+ overlap3 <- summariseCohortOverlap(cdm$cohort,
+                                   restrictToFirstEntry = TRUE,
+                                   timing = c("min",
+                                              "max"))
+ expect_equal(colnames(omopgenerics::emptySummarisedResult()),
+              colnames(overlap3))
+
+ overlap4 <- summariseCohortOverlap(cdm$cohort,
+                                   restrictToFirstEntry = TRUE,
+                                   timing = NULL)
+ expect_equal(colnames(omopgenerics::emptySummarisedResult()),
+              colnames(overlap4))
+
+ CDMConnector::cdm_disconnect(cdm)
+
+  })

vignettes/a02_applying_cohort_restrictions.Rmd

@@ -9,15 +9,15 @@ vignette: >
 
 ```{r, include = FALSE}
 library(CDMConnector)
-if (Sys.getenv("EUNOMIA_DATA_FOLDER") == "") {
-Sys.setenv("EUNOMIA_DATA_FOLDER" = file.path(tempdir(), "eunomia"))  
-} 
-if (!dir.exists(file.path(tempdir(), "eunomia"))){ dir.create(file.path(tempdir(), "eunomia"))
-}
-if (!eunomia_is_available()) {
-downloadEunomiaData(pathToData = file.path(tempdir(), "eunomia"))  
-}
-
+# if (Sys.getenv("EUNOMIA_DATA_FOLDER") == "") {
+# Sys.setenv("EUNOMIA_DATA_FOLDER" = file.path(tempdir(), "eunomia"))  
+# } 
+# if (!dir.exists(file.path(tempdir(), "eunomia"))){ dir.create(file.path(tempdir(), "eunomia"))
+# }
+# if (!eunomia_is_available()) {
+# downloadEunomiaData(pathToData = file.path(tempdir(), "eunomia"))  
+# }
+# 
 eunomia_available <- eunomia_is_available()
 
 knitr::opts_chunk$set(