Release 1.5.0

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: PatientProfiles
 Type: Package
 Title: Identify Characteristics of Patients in the OMOP Common Data Model
-Version: 1.4.5
+Version: 1.5.0
 Authors@R: c(
     person("Martí", "Català", , "marti.catalasabate@ndorms.ox.ac.uk", 
     role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3308-9905")),
@@ -71,3 +71,4 @@ Depends:
 Config/testthat/edition: 3
 Config/testthat/parallel: true
 VignetteBuilder: knitr
+Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -2,11 +2,14 @@
 
 export(addAge)
 export(addAgeQuery)
+export(addBirthday)
+export(addBirthdayQuery)
 export(addCategories)
 export(addCdmName)
 export(addCohortIntersectCount)
 export(addCohortIntersectDate)
 export(addCohortIntersectDays)
+export(addCohortIntersectField)
 export(addCohortIntersectFlag)
 export(addCohortName)
 export(addConceptIntersectCount)
@@ -51,6 +54,7 @@ export(startDateColumn)
 export(summariseResult)
 export(suppress)
 export(variableTypes)
+importFrom(lifecycle,deprecated)
 importFrom(omopgenerics,settings)
 importFrom(omopgenerics,suppress)
 importFrom(rlang,"%||%")

NEWS.md

@@ -1,3 +1,10 @@
+# PatientProfiles 1.5.0
+
+* Fix tests for dplyr 1.2.0 by @catalamarti in #842
+* add ageUnit to age functions by @catalamarti in #840
+* addCohortIntersectField by @catalamarti in #843
+* addBirthDay function by @catalamarti in #841
+
 # PatientProfiles 1.4.5
 
 * Add new estimates count_0, count_negative, count_positive, count_not_positive, count_not_negative + percentages by @catalamarti in #825

R/PatientProfiles-package.R

@@ -18,6 +18,7 @@
 "_PACKAGE"
 
 ## usethis namespace: start
+#' @importFrom lifecycle deprecated
 #' @importFrom rlang %||%
 #' @importFrom rlang .data
 #' @importFrom rlang .env

R/addBirthDay.R

@@ -0,0 +1,189 @@
+#' Add the birth day of an individual to a table
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' The function accounts for leap years and corrects the invalid dates to the
+#' next valid date.
+#'
+#' @inheritParams addDemographics
+#' @param birthday Number of birth day.
+#' @param birthdayName Birth day variable name.
+#'
+#' @return The table with a new column containing the birth day.
+#' @export
+#'
+#' @examples
+#' \donttest{
+#' library(PatientProfiles)
+#' library(dplyr)
+#'
+#' cdm <- mockPatientProfiles(source = "duckdb")
+#'
+#' cdm$cohort1 |>
+#'   addBirthday() |>
+#'   glimpse()
+#'
+#' cdm$cohort1 |>
+#'   addBirthday(birthday = 5, birthdayName = "bithday_5th") |>
+#'   glimpse()
+#' }
+#'
+addBirthday <- function(x,
+                        birthday = 0,
+                        birthdayName = "birthday",
+                        ageMissingMonth = 1L,
+                        ageMissingDay = 1L,
+                        ageImposeMonth = FALSE,
+                        ageImposeDay = FALSE,
+                        name = NULL) {
+  name <- omopgenerics::validateNameArgument(name = name, null = TRUE)
+  .addBirthdayQuery(
+    x = x,
+    birthdayName = birthdayName,
+    birthday = birthday,
+    ageMissingMonth = ageMissingMonth,
+    ageMissingDay = ageMissingDay,
+    ageImposeMonth = ageImposeMonth,
+    ageImposeDay = ageImposeDay
+  ) |>
+    dplyr::compute(name = name)
+}
+
+#' Add the birth day of an individual to a table
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#' Same as `addBirthday()`, except query is not computed to a table.
+#'
+#' The function accounts for leap years and corrects the invalid dates to the
+#' next valid date.
+#'
+#' @inheritParams addBirthday
+#'
+#' @return The table with a query that add the new column containing the birth
+#' day.
+#' @export
+#'
+#' @examples
+#' \donttest{
+#' library(PatientProfiles)
+#' library(dplyr)
+#'
+#' cdm <- mockPatientProfiles(source = "duckdb")
+#'
+#' cdm$cohort1 |>
+#'   addBirthdayQuery() |>
+#'   glimpse()
+#'
+#' cdm$cohort1 |>
+#'   addBirthdayQuery(birthday = 5) |>
+#'   glimpse()
+#' }
+#'
+addBirthdayQuery <- function(x,
+                             birthdayName = "birthday",
+                             birthday = 0,
+                             ageMissingMonth = 1,
+                             ageMissingDay = 1,
+                             ageImposeMonth = FALSE,
+                             ageImposeDay = FALSE) {
+  .addBirthdayQuery(
+    x = x,
+    birthdayName = birthdayName,
+    birthday = birthday,
+    ageMissingMonth = ageMissingMonth,
+    ageMissingDay = ageMissingDay,
+    ageImposeMonth = ageImposeMonth,
+    ageImposeDay = ageImposeDay
+  )
+}
+
+.addBirthdayQuery <- function(x,
+                              birthdayName,
+                              birthday,
+                              ageMissingMonth,
+                              ageMissingDay,
+                              ageImposeMonth,
+                              ageImposeDay,
+                              call = parent.frame()) {
+  # initial checks
+  x <- omopgenerics::validateCdmTable(table = x, call = call)
+  id <- omopgenerics::getPersonIdentifier(x = x, call = call)
+  x <- omopgenerics::validateNewColumn(table = x, column = birthdayName, call = call)
+  omopgenerics::assertNumeric(birthday, integerish = TRUE, length = 1, call = call)
+  ageMissingMonth <- validateAgeMissingMonth(ageMissingMonth, null = FALSE, call = call)
+  ageMissingDay <- validateAgeMissingDay(ageMissingDay, null = FALSE, call = call)
+  omopgenerics::assertLogical(ageImposeMonth, length = 1, call = call)
+  omopgenerics::assertLogical(ageImposeDay, length = 1, call = call)
+
+  cdm <- omopgenerics::cdmReference(table = x)
+
+  # correct day
+  if (ageImposeDay | !"day_of_birth" %in% colnames(cdm$person)) {
+    qD <- "{ageMissingDay}L"
+  } else {
+    qD <- "dplyr::coalesce(as.integer(.data$day_of_birth), {ageMissingDay}L)"
+  }
+
+  # correct month
+  if (ageImposeMonth | !"month_of_birth" %in% colnames(cdm$person)) {
+    qM <- "{ageMissingMonth}L"
+  } else {
+    qM <- "dplyr::coalesce(as.integer(.data$month_of_birth), {ageMissingMonth}L)"
+  }
+
+  # add number of years
+  qY <- paste0("as.integer(.data$year_of_birth + ", as.integer(birthday), "L)")
+
+  # correct day of birth depending on leap year
+  qLp <- "dplyr::case_when(
+    .data$year_of_birth %% 4 == 0 & (.data$year_of_birth %% 100 != 0 | .data$year_of_birth %% 400 == 0) & .data$day_of_birth == 29L & .data$month_of_birth == 2L ~ 0L,
+    .data$day_of_birth == 29L & .data$month_of_birth == 2L ~ 1L,
+    .default = 0L
+  )"
+
+  # date of interest
+  if (inherits(x, "tbl_duckdb_connection")) {
+    qDt <- "dplyr::case_when(
+      is.na(.data$year_of_birth) ~ as.Date(NA),
+      .data$correct_leap_year == 0 ~ dbplyr::sql('make_date(year_of_birth, month_of_birth, day_of_birth)'),
+      .data$correct_leap_year == 1 ~ dbplyr::sql('make_date(year_of_birth, 3, 1)')
+    )"
+  } else {
+    qDt <- "dplyr::case_when(
+      is.na(.data$year_of_birth) ~ as.Date(NA),
+      .data$correct_leap_year == 0 ~ clock::date_build(year = .data$year_of_birth, month = .data$month_of_birth, day = .data$day_of_birth{ft}),
+      .data$correct_leap_year == 1 ~ clock::date_build(year = .data$year_of_birth, month = 3L, day = 1L)
+    )"
+  }
+
+  if (inherits(x, "data.frame")) {
+    ft <- ", invalid = 'next'"
+  } else {
+    ft <- ""
+  }
+
+  q <- c(qD, qM, qY, qLp, qDt) |>
+    purrr::map_chr(\(x) glue::glue(
+      x,
+      ageMissingDay = ageMissingDay,
+      ageMissingMonth = ageMissingMonth,
+      ft = ft
+    )) |>
+    rlang::set_names(c(
+      "day_of_birth", "month_of_birth", "year_of_birth", "correct_leap_year",
+      birthdayName
+    )) |>
+    rlang::parse_exprs()
+
+  sel <- rlang::set_names(c("person_id", birthdayName), c(id, birthdayName))
+
+  x |>
+    dplyr::left_join(
+      cdm$person |>
+        dplyr::mutate(!!!q) |>
+        dplyr::select(dplyr::all_of(sel)),
+      by = id
+    )
+}

R/addCohortIntersect.R

@@ -304,3 +304,86 @@ addCohortIntersectDate <- function(x,
 
   return(x)
 }
+
+#' It creates a column with the field of a desired intersection
+#'
+#' @param x Table with individuals in the cdm.
+#' @param targetCohortTable name of the cohort that we want to check for overlap.
+#' @param field Column of interest in the targetCohort.
+#' @param targetCohortId vector of cohort definition ids to include.
+#' @param indexDate Variable in x that contains the date to compute the
+#' intersection.
+#' @param censorDate whether to censor overlap events at a specific date
+#' or a column date of x.
+#' @param targetDate Date of interest in the other cohort table. Either
+#' cohort_start_date or cohort_end_date.
+#' @param order date to use if there are multiple records for an
+#' individual during the window of interest. Either first or last.
+#' @param window Window of time to identify records relative to the indexDate.
+#' Records outside of this time period will be ignored.
+#' @param nameStyle naming of the added column or columns, should include
+#' required parameters.
+#' @param name Name of the new table, if NULL a temporary table is returned.
+#'
+#' @return table with added columns with overlap information.
+#' @export
+#'
+#' @examples
+#' \donttest{
+#' library(PatientProfiles)
+#' library(dplyr)
+#'
+#' cdm <- mockPatientProfiles(source = "duckdb")
+#'
+#' cdm$cohort2 <- cdm$cohort2 |>
+#'   mutate(even = if_else(subject_id %% 2, "yes", "no")) |>
+#'   compute(name = "cohort2")
+#'
+#' cdm$cohort1 |>
+#'   addCohortIntersectFlag(
+#'     targetCohortTable = "cohort2"
+#'   )
+#'
+#' }
+#'
+addCohortIntersectField <- function(x,
+                                    targetCohortTable,
+                                    field,
+                                    targetCohortId = NULL,
+                                    indexDate = "cohort_start_date",
+                                    censorDate = NULL,
+                                    targetDate = "cohort_start_date",
+                                    order = "first",
+                                    window = list(c(0, Inf)),
+                                    nameStyle = "{cohort_name}_{field}_{window_name}",
+                                    name = NULL) {
+  cdm <- omopgenerics::cdmReference(x)
+  omopgenerics::assertCharacter(targetCohortTable)
+  omopgenerics::validateCdmArgument(cdm = cdm, requiredTables = targetCohortTable)
+  parameters <- checkCohortNames(cdm[[targetCohortTable]], {{targetCohortId}}, targetCohortTable)
+  nameStyle <- gsub("\\{cohort_name\\}", "\\{id_name\\}", nameStyle)
+  nameStyle <- gsub("\\{field\\}", "\\{value\\}", nameStyle)
+
+  if (missing(order) & rlang::is_interactive()) {
+    messageOrder(order)
+  }
+
+  x <- x |>
+    .addIntersect(
+      tableName = targetCohortTable,
+      filterVariable = parameters$filter_variable,
+      filterId = parameters$filter_id,
+      idName = parameters$id_name,
+      value = field,
+      indexDate = indexDate,
+      targetStartDate = targetDate,
+      targetEndDate = NULL,
+      window = window,
+      order = order,
+      nameStyle = nameStyle,
+      censorDate = censorDate,
+      name = name
+    )
+
+  return(x)
+}