Merge branch 'main' into og_validate

OHDSI · Sep 23, 2024 · cb9c682 · cb9c682
2 parents 58f42b0 + 01d8154
commit cb9c682
Show file tree

Hide file tree

Showing 26 changed files with 395 additions and 335 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -33,7 +33,7 @@ Imports:
     glue,
     magrittr,
     omopgenerics (>= 0.2.1),
-    PatientProfiles (>= 1.1.0),
+    PatientProfiles (>= 1.2.0),
     purrr,
     rlang,
     tidyr,
@@ -68,5 +68,4 @@ Depends:
     R (>= 4.1)
 URL: https://ohdsi.github.io/CohortConstructor/
 Remotes:
-    darwin-eu-dev/PatientProfiles
     darwin-eu/visOmopResults
diff --git a/R/mockCohortConstructor.R b/R/mockCohortConstructor.R
@@ -46,10 +46,10 @@ mockCohortConstructor <- function(nPerson = 10,
   if (is.null(tables)) {
     cdm <- omock::mockCdmReference() |>
       omock::mockVocabularyTables(concept = conceptTable) |>
-      omock::mockPerson(nPerson = nPerson) |>
-      omock::mockObservationPeriod() |>
-      omock::mockCohort(name = "cohort1") |>
-      omock::mockCohort(name = "cohort2", numberCohorts = 2)
+      omock::mockPerson(nPerson = nPerson,seed = seed) |>
+      omock::mockObservationPeriod(seed = seed) |>
+      omock::mockCohort(name = "cohort1", seed = seed) |>
+      omock::mockCohort(name = "cohort2", numberCohorts = 2, seed = seed)
   } else {
     cdm <- omock::mockCdmFromTables(tables = tables, seed = seed) |>
       omock::mockVocabularyTables(concept = conceptTable)
@@ -60,19 +60,19 @@ mockCohortConstructor <- function(nPerson = 10,
   }
 
   if (drugExposure) {
-    cdm <- cdm |> omock::mockDrugExposure()
+    cdm <- cdm |> omock::mockDrugExposure(seed = seed)
   }
 
   if (conditionOccurrence) {
-    cdm <- cdm |> omock::mockConditionOccurrence()
+    cdm <- cdm |> omock::mockConditionOccurrence(seed = seed)
   }
 
   if (death) {
-    cdm <- cdm |> omock::mockDeath()
+    cdm <- cdm |> omock::mockDeath(seed = seed)
   }
 
   if (measurement) {
-    cdm <- cdm |> omock::mockMeasurement()
+    cdm <- cdm |> omock::mockMeasurement(seed = seed)
   }
 
   if (!is.null(otherTables)) {

diff --git a/R/requireConceptIntersect.R b/R/requireConceptIntersect.R
@@ -23,7 +23,7 @@
 #' cdm <- mockCohortConstructor(conditionOccurrence = TRUE)
 #' cdm$cohort2 <-  requireConceptIntersect(
 #'   cohort = cdm$cohort1,
-#'   conceptSet = list(a = 1),
+#'   conceptSet = list(a = 194152),
 #'   window = c(-Inf, 0),
 #'   name = "cohort2")
 #'   }

diff --git a/R/sampleCohorts.R b/R/sampleCohorts.R
@@ -5,7 +5,7 @@
 #' people. All records of these individuals are preserved.
 #'
 #' @inheritParams cohortDoc
-#' @inheritParams cohortIdSubsetDoc
+#' @inheritParams cohortIdModifyDoc
 #' @inheritParams nameDoc
 #' @param n Number of people to be sampled for each included cohort.
 #'

diff --git a/R/unionCohorts.R b/R/unionCohorts.R
@@ -65,15 +65,17 @@ unionCohorts <- function(cohort,
   tmpTable  <- omopgenerics::uniqueTableName()
   unionedCohort <- cohort |>
     dplyr::filter(.data$cohort_definition_id %in% .env$cohortId) |>
-    joinOverlap(name = name, by = "subject_id", gap = gap) |>
+    joinOverlap(name = tmpTable,
+                by = "subject_id",
+                gap = gap) |>
     dplyr::mutate(cohort_definition_id = 1L) |>
+    dplyr::relocate(dplyr::all_of(omopgenerics::cohortColumns("cohort"))) |>
     dplyr::compute(name = tmpTable, temporary = FALSE)
   cohCodelist <- attr(cohort, "cohort_codelist")
   if (!is.null(cohCodelist)) {
     cohCodelist <- cohCodelist |> dplyr::mutate("cohort_definition_id" = 1L)
   }
   unionedCohort <- unionedCohort |>
-    dplyr::relocate(dplyr::all_of(omopgenerics::cohortColumns("cohort"))) |>
     omopgenerics::newCohortTable(
       cohortSetRef = cohSet,
       cohortAttritionRef = NULL,
@@ -88,6 +90,7 @@ unionCohorts <- function(cohort,
     cdm <- bind(cohort, unionedCohort, name = name)
   }
 
+  CDMConnector::dropTable(cdm, name = tmpTable)
 
   return(cdm[[name]])
 }
diff --git a/README.Rmd b/README.Rmd
@@ -18,6 +18,7 @@ knitr::opts_chunk$set(
 <!-- badges: start -->
 [![CRAN status](https://www.r-pkg.org/badges/version/CohortConstructor)](https://CRAN.R-project.org/package=CohortConstructor)
 [![R-CMD-check](https://github.com/OHDSI/CohortConstructor/workflows/R-CMD-check/badge.svg)](https://github.com/OHDSI/CohortConstructor/actions)
+[![Codecov test coverage](https://codecov.io/gh/OHDSI/CohortConstructor/branch/main/graph/badge.svg)](https://app.codecov.io/gh/OHDSI/CohortConstructor?branch=main)
 [![Lifecycle:Experimental](https://img.shields.io/badge/Lifecycle-Experimental-339999)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
 
 <!-- badges: end -->

diff --git a/README.md b/README.md
@@ -8,6 +8,8 @@
 [![CRAN
 status](https://www.r-pkg.org/badges/version/CohortConstructor)](https://CRAN.R-project.org/package=CohortConstructor)
 [![R-CMD-check](https://github.com/OHDSI/CohortConstructor/workflows/R-CMD-check/badge.svg)](https://github.com/OHDSI/CohortConstructor/actions)
+[![Codecov test
+coverage](https://codecov.io/gh/OHDSI/CohortConstructor/branch/main/graph/badge.svg)](https://app.codecov.io/gh/OHDSI/CohortConstructor?branch=main)
 [![Lifecycle:Experimental](https://img.shields.io/badge/Lifecycle-Experimental-339999)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
 
 <!-- badges: end -->
@@ -112,14 +114,14 @@ cohort_count(cdm$fractures) %>% glimpse()
 #> Rows: 3
 #> Columns: 3
 #> $ cohort_definition_id <int> 1, 2, 3
-#> $ number_records       <int> 462, 565, 137
-#> $ number_subjects      <int> 426, 508, 132
+#> $ number_records       <int> 464, 569, 138
+#> $ number_subjects      <int> 427, 510, 132
 attrition(cdm$fractures) %>% glimpse()
 #> Rows: 9
 #> Columns: 7
 #> $ cohort_definition_id <int> 1, 1, 1, 2, 2, 2, 3, 3, 3
-#> $ number_records       <int> 462, 462, 462, 565, 565, 565, 137, 137, 137
-#> $ number_subjects      <int> 426, 426, 426, 508, 508, 508, 132, 132, 132
+#> $ number_records       <int> 464, 464, 464, 569, 569, 569, 138, 138, 138
+#> $ number_subjects      <int> 427, 427, 427, 510, 510, 510, 132, 132, 132
 #> $ reason_id            <int> 1, 2, 3, 1, 2, 3, 1, 2, 3
 #> $ reason               <chr> "Initial qualifying events", "cohort requirements…
 #> $ excluded_records     <int> 0, 0, 0, 0, 0, 0, 0, 0, 0
@@ -134,21 +136,28 @@ our three cohorts to create this overall cohort like so:
 
 ``` r
 cdm$fractures <- unionCohorts(cdm$fractures,
-                                 cohortName = "any_fracture", 
-                                 name ="fractures")
+                              cohortName = "any_fracture", 
+                              keepOriginalCohorts = TRUE,
+                              name ="fractures")
 ```
 
 ``` r
 settings(cdm$fractures)
-#> # A tibble: 1 × 3
-#>   cohort_definition_id cohort_name    gap
-#>                  <int> <chr>        <dbl>
-#> 1                    1 any_fracture     0
+#> # A tibble: 4 × 5
+#>   cohort_definition_id cohort_name      cdm_version vocabulary_version   gap
+#>                  <int> <chr>            <chr>       <chr>              <dbl>
+#> 1                    1 ankle_fracture   5.3         v5.0 18-JAN-19        NA
+#> 2                    2 forearm_fracture 5.3         v5.0 18-JAN-19        NA
+#> 3                    3 hip_fracture     5.3         v5.0 18-JAN-19        NA
+#> 4                    4 any_fracture     <NA>        <NA>                   0
 cohortCount(cdm$fractures)
-#> # A tibble: 1 × 3
+#> # A tibble: 4 × 3
 #>   cohort_definition_id number_records number_subjects
 #>                  <int>          <int>           <int>
-#> 1                    1           1164             922
+#> 1                    1            464             427
+#> 2                    2            569             510
+#> 3                    3            138             132
+#> 4                    4           1171             924
 ```
 
 ### Require in date range
@@ -168,11 +177,11 @@ attributes have been updated
 
 ``` r
 cohort_count(cdm$fractures) %>% glimpse()
-#> Rows: 1
+#> Rows: 4
 #> Columns: 3
-#> $ cohort_definition_id <int> 1
-#> $ number_records       <int> 315
-#> $ number_subjects      <int> 282
+#> $ cohort_definition_id <int> 1, 2, 3, 4
+#> $ number_records       <int> 108, 152, 62, 322
+#> $ number_subjects      <int> 104, 143, 60, 287
 attrition(cdm$fractures) %>% 
   filter(reason == "cohort_start_date between 2000-01-01 & 2020-01-01") %>% 
   glimpse()
@@ -205,28 +214,28 @@ criteria.
 attrition(cdm$fractures) %>% 
   filter(reason == "Age requirement: 40 to 65") %>% 
   glimpse()
-#> Rows: 1
+#> Rows: 4
 #> Columns: 7
-#> $ cohort_definition_id <int> 1
-#> $ number_records       <int> 124
-#> $ number_subjects      <int> 118
-#> $ reason_id            <int> 4
-#> $ reason               <chr> "Age requirement: 40 to 65"
-#> $ excluded_records     <int> 191
-#> $ excluded_subjects    <int> 164
+#> $ cohort_definition_id <int> 1, 2, 3, 4
+#> $ number_records       <int> 43, 64, 22, 129
+#> $ number_subjects      <int> 43, 62, 22, 122
+#> $ reason_id            <int> 6, 6, 6, 4
+#> $ reason               <chr> "Age requirement: 40 to 65", "Age requirement: 40…
+#> $ excluded_records     <int> 65, 88, 40, 193
+#> $ excluded_subjects    <int> 61, 81, 38, 165
 
 attrition(cdm$fractures) %>% 
   filter(reason == "Sex requirement: Female") %>% 
   glimpse()
-#> Rows: 1
+#> Rows: 4
 #> Columns: 7
-#> $ cohort_definition_id <int> 1
-#> $ number_records       <int> 64
-#> $ number_subjects      <int> 62
-#> $ reason_id            <int> 5
-#> $ reason               <chr> "Sex requirement: Female"
-#> $ excluded_records     <int> 60
-#> $ excluded_subjects    <int> 56
+#> $ cohort_definition_id <int> 1, 2, 3, 4
+#> $ number_records       <int> 19, 37, 12, 68
+#> $ number_subjects      <int> 19, 36, 12, 65
+#> $ reason_id            <int> 7, 7, 7, 5
+#> $ reason               <chr> "Sex requirement: Female", "Sex requirement: Fema…
+#> $ excluded_records     <int> 24, 27, 10, 61
+#> $ excluded_subjects    <int> 24, 26, 10, 57
 ```
 
 ### Require presence in another cohort
@@ -251,15 +260,15 @@ cdm$fractures <- cdm$fractures %>%
 attrition(cdm$fractures) %>% 
   filter(reason == "Not in cohort gibleed between -Inf & 0 days relative to cohort_start_date") %>% 
   glimpse()
-#> Rows: 1
+#> Rows: 4
 #> Columns: 7
-#> $ cohort_definition_id <int> 1
-#> $ number_records       <int> 64
-#> $ number_subjects      <int> 62
-#> $ reason_id            <int> 8
+#> $ cohort_definition_id <int> 1, 2, 3, 4
+#> $ number_records       <int> 14, 30, 10, 54
+#> $ number_subjects      <int> 14, 30, 10, 52
+#> $ reason_id            <int> 10, 10, 10, 8
 #> $ reason               <chr> "Not in cohort gibleed between -Inf & 0 days rela…
-#> $ excluded_records     <int> 0
-#> $ excluded_subjects    <int> 0
+#> $ excluded_records     <int> 5, 7, 2, 14
+#> $ excluded_subjects    <int> 5, 6, 2, 13
 ```
 
 ``` r

diff --git a/man/requireConceptIntersect.Rd b/man/requireConceptIntersect.Rd
diff --git a/man/sampleCohorts.Rd b/man/sampleCohorts.Rd
diff --git a/tests/testthat/test-conceptCohort.R b/tests/testthat/test-conceptCohort.R
@@ -283,8 +283,8 @@ test_that("excluded concepts in codelist", {
 test_that("out of observation", {
   testthat::skip_on_cran()
   cdm_local <- omock::mockCdmReference() |>
-    omock::mockPerson(n = 4) |>
-    omock::mockObservationPeriod()
+    omock::mockPerson(n = 4, seed = 1) |>
+    omock::mockObservationPeriod(seed = 1)
   cdm_local$concept <- dplyr::tibble(
     "concept_id" = c(1, 2),
     "concept_name" = c("my concept 1", "my concept 2"),
@@ -343,8 +343,8 @@ test_that("out of observation", {
   # event starts out, end in (subject 3)
   # no concept 2
   cdm_local <- omock::mockCdmReference() |>
-    omock::mockPerson(n = 4) |>
-    omock::mockObservationPeriod()
+    omock::mockPerson(n = 4, seed = 1) |>
+    omock::mockObservationPeriod(seed = 1)
   cdm_local$concept <- dplyr::tibble(
     "concept_id" = c(1, 2),
     "concept_name" = c("my concept 1", "my concept 2"),
@@ -384,8 +384,8 @@ test_that("out of observation", {
   # out of observation (subject 3)
   # overlapping (subject 4)
   cdm_local <- omock::mockCdmReference() |>
-    omock::mockPerson(n = 4) |>
-    omock::mockObservationPeriod()
+    omock::mockPerson(n = 4, seed = 1) |>
+    omock::mockObservationPeriod(seed = 1)
   cdm_local$concept <- dplyr::tibble(
     "concept_id" = c(1, 2),
     "concept_name" = c("my concept 1", "my concept 2"),

diff --git a/tests/testthat/test-exitAtDate.R b/tests/testthat/test-exitAtDate.R
@@ -1,24 +1,24 @@
 test_that("exit at observation end", {
   cdm_local <- omock::mockCdmReference() |>
-    omock::mockPerson(n = 4) |>
-    omock::mockObservationPeriod() |>
-    omock::mockCohort(name = c("cohort"), numberCohorts = 2)
+    omock::mockPerson(n = 4,seed = 1) |>
+    omock::mockObservationPeriod(seed = 1) |>
+    omock::mockCohort(name = c("cohort"), numberCohorts = 2,seed = 1)
   cdm <- cdm_local |> copyCdm()
   # simple example - test it works
   cdm$cohort1 <- cdm$cohort |> exitAtObservationEnd(name = "cohort1")
   expect_true(all(cdm$cohort1 |> dplyr::pull(cohort_start_date) |> sort() ==
-                    c("1997-10-22", "2000-06-23", "2001-03-30", "2015-03-05", "2015-03-25")))
+                    c("1999-05-03", "2001-03-24", "2003-05-17", "2015-02-25")))
   expect_true(all(cdm$cohort1 |> dplyr::pull(cohort_end_date) |> sort() ==
-                    c("2013-06-29", "2013-06-29", "2013-12-31", "2015-10-11", "2015-10-11")))
-  expect_true(all(cdm$cohort1 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 3, 3, 4)))
+                    c("2003-06-15", "2013-06-29", "2013-06-29", "2015-10-11")))
+  expect_true(all(cdm$cohort1 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 2, 3)))
 
   # test cohort id and name
   cdm$cohort <- cdm$cohort |> exitAtObservationEnd(cohortId = 1)
   expect_true(all(cdm$cohort |> dplyr::pull(cohort_start_date) |> sort() ==
-                    c("1997-10-22", "2000-06-23", "2001-03-30", "2001-07-16", "2001-12-04", "2015-03-05", "2015-03-25")))
+                    c("1999-05-03", "2001-03-24", "2001-11-28", "2002-01-30", "2002-06-13", "2003-05-17", "2015-02-25")))
   expect_true(all(cdm$cohort |> dplyr::pull(cohort_end_date) |> sort() ==
-                    c("2001-07-15", "2001-12-03", "2006-09-27", "2013-06-29", "2013-12-31", "2015-07-06", "2015-10-11")))
-  expect_true(all(cdm$cohort |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 1, 1, 3, 3, 4)))
+                    c("2001-11-27", "2002-01-29", "2002-06-12", "2003-06-15", "2005-01-15", "2013-06-29", "2015-10-11")))
+  expect_true(all(cdm$cohort |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 1, 1, 1, 2, 3)))
   expect_true(all(attrition(cdm$cohort)$reason == c("Initial qualifying events", "Exit at observation period end date", "Initial qualifying events")))
 
   # additional columns warning
@@ -35,9 +35,9 @@ test_that("exit at observation end", {
 test_that("exit at death date", {
   testthat::skip_on_cran()
   cdm_local <- omock::mockCdmReference() |>
-    omock::mockPerson(n = 4) |>
-    omock::mockObservationPeriod() |>
-    omock::mockCohort(name = c("cohort"), numberCohorts = 2)
+    omock::mockPerson(n = 4,seed = 1) |>
+    omock::mockObservationPeriod(seed = 1) |>
+    omock::mockCohort(name = c("cohort"), numberCohorts = 2,seed = 1)
   cdm_local$death <- dplyr::tibble(
     person_id = 1:2,
     death_date = as.Date(c("2013-06-29", "2003-06-15")),
@@ -48,30 +48,30 @@ test_that("exit at death date", {
   # simple example - require death TRUE works
   cdm$cohort1 <- cdm$cohort |> exitAtDeath(requireDeath = TRUE, name = "cohort1")
   expect_true(all(cdm$cohort1 |> dplyr::pull(cohort_start_date) |> sort() ==
-                    c("2000-06-23", "2001-03-30")))
+                    c("1999-05-03", "2001-03-24", "2003-05-17")))
   expect_true(all(cdm$cohort1 |> dplyr::pull(cohort_end_date) |> sort() ==
-                    c("2013-06-29", "2013-06-29")))
-  expect_true(all(cdm$cohort1 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1)))
+                    c("2003-06-15", "2013-06-29", "2013-06-29")))
+  expect_true(all(cdm$cohort1 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 2)))
   expect_true(all(attrition(cdm$cohort1)$reason ==
                     c("Initial qualifying events", "No death recorded", "Exit at death", "Initial qualifying events", "No death recorded", "Exit at death")))
 
   # simple example - require death FALSE works
   cdm$cohort2 <- cdm$cohort |> exitAtDeath(requireDeath = FALSE, name = "cohort2")
   expect_true(all(cdm$cohort2 |> dplyr::pull(cohort_start_date) |> sort() ==
-                    c("1997-10-22", "2000-06-23", "2001-03-30", "2015-03-05", "2015-03-25")))
+                    c("1999-05-03", "2001-03-24", "2003-05-17", "2015-02-25")))
   expect_true(all(cdm$cohort2 |> dplyr::pull(cohort_end_date) |> sort() ==
-                    c("1999-05-28", "2013-06-29", "2013-06-29", "2015-04-14", "2015-07-06")))
-  expect_true(all(cdm$cohort2 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 3, 3, 4)))
+                    c("2003-06-15", "2013-06-29", "2013-06-29", "2015-04-30")))
+  expect_true(all(cdm$cohort2 |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 2, 3)))
   expect_true(all(attrition(cdm$cohort2)$reason ==
                     c("Initial qualifying events", "Exit at death", "Initial qualifying events", "Exit at death")))
 
   # cohort ID and name
   cdm$cohort <- cdm$cohort |> exitAtDeath(cohortId = 1, requireDeath = TRUE)
   expect_true(all(cdm$cohort |> dplyr::pull(cohort_start_date) |> sort() ==
-                    c("2000-06-23", "2001-03-30", "2001-07-16", "2001-12-04", "2015-03-05")))
+                    c("1999-05-03", "2001-03-24", "2001-11-28", "2002-01-30", "2002-06-13", "2003-05-17")))
   expect_true(all(cdm$cohort |> dplyr::pull(cohort_end_date) |> sort() ==
-                    c("2001-07-15", "2001-12-03", "2006-09-27", "2013-06-29", "2015-07-06")))
-  expect_true(all(cdm$cohort |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 1, 1, 3)))
+                    c("2001-11-27", "2002-01-29", "2002-06-12", "2003-06-15", "2005-01-15", "2013-06-29")))
+  expect_true(all(cdm$cohort |> dplyr::pull(subject_id) |> sort() ==  c(1, 1, 1, 1, 1, 2)))
   expect_true(all(attrition(cdm$cohort)$reason ==
                     c("Initial qualifying events", "No death recorded", "Exit at death", "Initial qualifying events")))