Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

require funs #8

Merged
merged 1 commit into from
Dec 3, 2023
Merged

require funs #8

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ Imports:
cli,
dbplyr,
dplyr,
glue,
magrittr,
PatientProfiles,
rlang,
Expand Down
5 changes: 5 additions & 0 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,11 @@
export(generateCombinationCohortSet)
export(getIdentifier)
export(joinOverlap)
export(requireAge)
export(requireDemographics)
export(requireFutureObservation)
export(requirePriorObservation)
export(requireSex)
export(splitOverlap)
importFrom(magrittr,"%>%")
importFrom(rlang,":=")
Expand Down
242 changes: 242 additions & 0 deletions R/requireDemographics.R
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,242 @@


#' Restrict cohort on patient demographics
#'
#' @param cohort A cohort table in a cdm reference
#' @param indexDate Variable in cohort that contains the date to compute the
#' demographics characteristics on which to restrict on.
#' @param ageRange A list of minimum and maximum age
#' @param sex Can be "Both", "Male" or "Female". If one of the latter, only
#' those with that sex will be included.
#' @param minPriorObservation A mimimum number of prior observation days in
#' the database.
#' @param minFutureObservation A minimum number of future observation days in
#' the database.
#'
#' @return
#' @export
#'
#' @examples
requireDemographics <- function(cohort,
indexDate = "cohort_start_date",
ageRange = list(c(0, 150)),
sex = c("Both"),
minPriorObservation = 0,
minFutureObservation = 0){

cohort <- demographicsFilter(cohort = cohort,
indexDate = indexDate,
ageRange = ageRange,
sex = sex,
minPriorObservation = minPriorObservation,
minFutureObservation = minFutureObservation)

cohort <- cohort %>%
CDMConnector::recordCohortAttrition(reason = "Demographic requirements")

cohort
}

#' Restrict cohort on age
#'
#' @param cohort A cohort table in a cdm reference
#' @param indexDate Variable in cohort that contains the date to compute the
#' demographics characteristics on which to restrict on.
#' @param ageRange A list of minimum and maximum age
#'
#' @return
#' @export
#'
#' @examples
requireAge <- function(cohort,
indexDate = "cohort_start_date",
ageRange = list(c(0, 150))){

cohort <- demographicsFilter(cohort = cohort,
indexDate = indexDate,
ageRange = ageRange,
sex = "Both",
minPriorObservation = 0,
minFutureObservation = 0)

cohort <- cohort %>%
CDMConnector::recordCohortAttrition(reason =
glue::glue("Age requirement: {ageRange[[1]][1]} to {ageRange[[1]][2]}"))

cohort

}

#' Restrict cohort on sex
#'
#' @param cohort A cohort table in a cdm reference
#' @param sex Can be "Both", "Male" or "Female". If one of the latter, only
#' those with that sex will be included.
#'
#' @return
#' @export
#'
#' @examples
requireSex <- function(cohort,
sex = c("Both")){

cohort <- demographicsFilter(cohort = cohort,
indexDate = "cohort_start_date",
ageRange = list(c(0, 150)),
sex = sex,
minPriorObservation = 0,
minFutureObservation = 0)

cohort <- cohort %>%
CDMConnector::recordCohortAttrition(reason =
glue::glue("Sex requirement: {sex}"))


cohort

}

#' Restrict cohort on prior observation
#'
#' @param cohort A cohort table in a cdm reference
#' @param indexDate Variable in cohort that contains the date to compute the
#' demographics characteristics on which to restrict on.
#' @param minPriorObservation A mimimum number of prior observation days in
#' the database.
#'
#' @return
#' @export
#'
#' @examples
requirePriorObservation <- function(cohort,
indexDate = "cohort_start_date",
minPriorObservation = 0){

cohort <- demographicsFilter(cohort = cohort,
indexDate = indexDate,
ageRange = list(c(0, 150)),
sex = "Both",
minPriorObservation = minPriorObservation,
minFutureObservation = 0)

cohort <- cohort %>%
CDMConnector::recordCohortAttrition(reason =
glue::glue("Prior observation requirement: {minPriorObservation} days"))

cohort

}

#' Restrict cohort on future observation
#'
#' @param cohort A cohort table in a cdm reference
#' @param indexDate Variable in cohort that contains the date to compute the
#' demographics characteristics on which to restrict on.
#' @param minFutureObservation A minimum number of future observation days in
#' the database.
#'
#' @return
#' @export
#'
#' @examples
requireFutureObservation <- function(cohort,
indexDate = "cohort_start_date",
minFutureObservation = 0){

cohort <- demographicsFilter(cohort = cohort,
indexDate = indexDate,
ageRange = list(c(0, 150)),
sex = "Both",
minPriorObservation = 0,
minFutureObservation = minFutureObservation)

cohort <- cohort %>%
CDMConnector::recordCohortAttrition(reason =
glue::glue("Future observation requirement: {minFutureObservation} days"))

cohort

}

demographicsFilter <- function(cohort,
indexDate,
ageRange,
sex,
minPriorObservation,
minFutureObservation){

cdm <- attr(cohort, "cdm_reference")

# validate inputs
if (!isTRUE(inherits(cdm, "cdm_reference"))) {
cli::cli_abort("cohort must be part of a cdm reference")
}
if(!"GeneratedCohortSet" %in% class(cohort) ||
!all(c("cohort_definition_id", "subject_id",
"cohort_start_date", "cohort_end_date") %in%
colnames(cohort))){
cli::cli_abort("cohort must be a GeneratedCohortSet")
}
if(!indexDate %in% colnames(cohort)){
cli::cli_abort("indexDate must be a date column in the cohort table")
}

if(!is.list(ageRange)){
cli::cli_abort("ageRange must be a list")
}
if(length(ageRange[[1]]) != 2 ||
!is.numeric(ageRange[[1]]) ||
!ageRange[[1]][2] >= ageRange[[1]][1] ||
!ageRange[[1]][1]>=0){
cli::cli_abort("ageRange only contain a vector of length two, with the
second number greater or equal to the first")
}
if(length(ageRange) != 1){
cli::cli_abort("Only a single ageRange is currently supported")
}
if(!all(sex %in% c("Both", "Male", "Female"))){
cli::cli_abort("sex must be Both, Male, or Female")
}
if(length(sex) != 1){
cli::cli_abort("Only a single sex option is currently supported")
}
if(!is.numeric(minPriorObservation) ||
length(minPriorObservation) != 1 ||
!minPriorObservation >= 0){
cli::cli_abort("minPriorObservation must be a positive number")
}
if(!is.numeric(minFutureObservation) ||
length(minFutureObservation) != 1 ||
!minFutureObservation >= 0){
cli::cli_abort("minFutureObservation must be a positive number")
}

minAge <- ageRange[[1]][1]
maxAge <- ageRange[[1]][2]
if(sex == "Both"){
sex <- c("Male", "Female")
}

# because the cohort table passed to the function might have extra columns
# that would conflict with ones we'll add, we'll take the core table first
# join later

working_cohort <- cohort %>%
dplyr::select(c("cohort_definition_id", "subject_id",
"cohort_start_date", "cohort_end_date",
indexDate)) %>%
PatientProfiles::addDemographics(indexDate = indexDate) %>%
dplyr::filter(.data$age >= .env$minAge,
.data$age <= .env$maxAge,
.data$sex %in% .env$sex,
.data$prior_observation >= .env$minPriorObservation,
.data$future_observation >= .env$minFutureObservation)

cohort <- cohort %>%
dplyr::inner_join(working_cohort %>%
dplyr::select(c("cohort_definition_id", "subject_id",
"cohort_start_date", "cohort_end_date")),
by = c("cohort_definition_id", "subject_id",
"cohort_start_date", "cohort_end_date"))
cohort
}
51 changes: 42 additions & 9 deletions README.Rmd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ knitr::opts_chunk$set(
[![Lifecycle:Experimental](https://img.shields.io/badge/Lifecycle-Experimental-339999)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
<!-- badges: end -->

The goal of CohortConstructor is to help on the creation of cohorts in the OMOP Common Data Model.
The goal of CohortConstructor is to help on the creation and manipulation of cohorts in the OMOP Common Data Model.

## Installation

Expand All @@ -33,21 +33,54 @@ You can install the development version of CohortConstructor from [GitHub](https
devtools::install_github("oxford-pharmacoepi/CohortConstructor")
```

## Example
## Example usage

``` {r}
library(CDMConnector)
library(PatientProfiles)
library(CohortConstructor)

con <- DBI::dbConnect(duckdb::duckdb(), dbdir = eunomia_dir())
cdm <- cdm_from_con(con, cdm_schema = "main",
write_schema = c(prefix = "my_study_", schema = "main"))
```

### Generating concept based cohorts
``` {r}
cdm <- generate_concept_cohort_set(cdm = cdm,
name = "medications",
concept_set = list("diclofenac" = 1124300,
"acetaminophen" = 1127433))
cohortSet(cdm$combinations)
cohort_count(cdm$medications)
cohort_attrition(cdm$medications)
```

### Applying demographic requirements
``` {r}
cdm$medications %>%
requireDemographics(ageRange = list(c(40, 65)),
sex = "Female")
cohortSet(cdm$combinations)
cohort_count(cdm$medications)
cohort_attrition(cdm$medications)
```


### Combining cohorts

Generate a combination cohort.

```{r}
library(PatientProfiles)
library(CohortConstructor)
library(CDMConnector)
cdm <- generateCombinationCohortSet(cdm = cdm,
name = "combinations",
targetCohortName = "medications")


cdm <- mockPatientProfiles()
cdm <- generateCombinationCohortSet(cdm = cdm, name = "cohort3", targetCohortName = "cohort2")

cdm$cohort3
cohortSet(cdm$combinations)
cohortCount(cdm$combinations)

cohortSet(cdm$cohort3)

cdmDisconnect(cdm)
```
Expand Down
Loading