diff --git a/DESCRIPTION b/DESCRIPTION index a2f10ca2..f38c2f32 100644 --- a/DESCRIPTION +++ b/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) diff --git a/NAMESPACE b/NAMESPACE index 1407db96..1dc4aff0 100644 --- a/NAMESPACE +++ b/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,"%||%") diff --git a/NEWS.md b/NEWS.md index 3ad8d457..ee9ece0c 100644 --- a/NEWS.md +++ b/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 diff --git a/R/PatientProfiles-package.R b/R/PatientProfiles-package.R index a9966848..0b617662 100644 --- a/R/PatientProfiles-package.R +++ b/R/PatientProfiles-package.R @@ -18,6 +18,7 @@ "_PACKAGE" ## usethis namespace: start +#' @importFrom lifecycle deprecated #' @importFrom rlang %||% #' @importFrom rlang .data #' @importFrom rlang .env diff --git a/R/addBirthDay.R b/R/addBirthDay.R new file mode 100644 index 00000000..9bc02710 --- /dev/null +++ b/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 + ) +} diff --git a/R/addCohortIntersect.R b/R/addCohortIntersect.R index 318a056a..423b5db7 100644 --- a/R/addCohortIntersect.R +++ b/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) +} diff --git a/R/addDemographics.R b/R/addDemographics.R index d3b7a7c4..cbcecbbf 100644 --- a/R/addDemographics.R +++ b/R/addDemographics.R @@ -30,6 +30,7 @@ #' will be considered as missing for all the individuals. #' @param ageImposeDay TRUE or FALSE. Whether the day of the date of birth #' will be considered as missing for all the individuals. +#' @param ageUnit Unit for age it can either be 'years', 'months' or 'days'. #' @param ageGroup if not NULL, a list of ageGroup vectors. #' @param missingAgeGroupValue Value to include if missing age. #' @param sex TRUE or FALSE. If TRUE, sex will be identified. @@ -72,6 +73,7 @@ addDemographics <- function(x, ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", ageGroup = NULL, missingAgeGroupValue = "None", sex = TRUE, @@ -100,6 +102,7 @@ addDemographics <- function(x, ageMissingMonth = ageMissingMonth, ageImposeDay = ageImposeDay, ageImposeMonth = ageImposeMonth, + ageUnit = ageUnit, sex = sex, sexName = sexName, missingSexValue = missingSexValue, @@ -124,20 +127,7 @@ addDemographics <- function(x, #' Compute the age of the individuals at a certain date #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the age. -#' @param ageName Name of the new column that contains age. -#' @param ageGroup List of age groups to be added. -#' @param ageMissingMonth Month of the year assigned to individuals with missing -#' month of birth. By default: 1. -#' @param ageMissingDay day of the month assigned to individuals with missing -#' day of birth. By default: 1. -#' @param ageImposeMonth Whether the month of the date of birth will be -#' considered as missing for all the individuals. -#' @param ageImposeDay Whether the day of the date of birth will be considered -#' as missing for all the individuals. -#' @param missingAgeGroupValue Value to include if missing age. -#' @param name Name of the new table, if NULL a temporary table is returned. +#' @inheritParams addDemographics #' #' @return tibble with the age column added. #' @export @@ -160,6 +150,7 @@ addAge <- function(x, ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", missingAgeGroupValue = "None", name = NULL) { name <- validateName(name) @@ -173,6 +164,7 @@ addAge <- function(x, ageMissingMonth = ageMissingMonth, ageImposeDay = ageImposeDay, ageImposeMonth = ageImposeMonth, + ageUnit = ageUnit, missingAgeGroupValue = missingAgeGroupValue, sex = FALSE, priorObservation = FALSE, @@ -193,13 +185,7 @@ addAge <- function(x, #' Compute the number of days till the end of the observation period at a #' certain date #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the future -#' observation. -#' @param futureObservationName name of the new column to be added. -#' @param futureObservationType Whether to return a "date" or the number of -#' "days". -#' @param name Name of the new table, if NULL a temporary table is returned. +#' @inheritParams addDemographics #' #' @return cohort table with added column containing future observation of the #' individuals. @@ -234,6 +220,7 @@ addFutureObservation <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = FALSE, priorObservation = FALSE, futureObservation = TRUE, @@ -259,13 +246,7 @@ addFutureObservation <- function(x, #' Compute the number of days of prior observation in the current observation period #' at a certain date #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the prior -#' observation. -#' @param priorObservationName name of the new column to be added. -#' @param priorObservationType Whether to return a "date" or the number of -#' "days". -#' @param name Name of the new table, if NULL a temporary table is returned. +#' @inheritParams addDemographics #' #' @return cohort table with added column containing prior observation of the #' individuals. @@ -301,6 +282,7 @@ addPriorObservation <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = FALSE, priorObservation = TRUE, priorObservationName = priorObservationName, @@ -377,10 +359,7 @@ addInObservation <- function(x, #' Compute the sex of the individuals #' -#' @param x Table with individuals in the cdm. -#' @param sexName name of the new column to be added. -#' @param missingSexValue Value to include if missing sex. -#' @param name Name of the new table, if NULL a temporary table is returned. +#' @inheritParams addDemographics #' #' @return table x with the added column with sex information. #' @@ -411,6 +390,7 @@ addSex <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = TRUE, sexName = sexName, missingSexValue = missingSexValue, @@ -430,14 +410,15 @@ addSex <- function(x, #' Add a column with the individual birth date #' -#' @param x Table in the cdm that contains 'person_id' or 'subject_id'. -#' @param dateOfBirthName Name of the column to be added with the date of birth. -#' @param missingDay Day of the individuals with no or imposed day of birth. -#' @param missingMonth Month of the individuals with no or imposed month of -#' birth. -#' @param imposeDay Whether to impose day of birth. -#' @param imposeMonth Whether to impose month of birth. -#' @param name Name of the new table, if NULL a temporary table is returned. +#' @inheritParams addDemographics +#' @param missingMonth Month of the year assigned to individuals with missing +#' month of birth. +#' @param missingDay day of the month assigned to individuals +#' with missing day of birth. +#' @param imposeMonth TRUE or FALSE. Whether the month of the date of birth +#' will be considered as missing for all the individuals. +#' @param imposeDay TRUE or FALSE. Whether the day of the date of birth +#' will be considered as missing for all the individuals. #' #' @return The function returns the table x with an extra column that contains #' the date of birth. @@ -471,6 +452,7 @@ addDateOfBirth <- function(x, ageMissingMonth = missingMonth, ageImposeDay = imposeDay, ageImposeMonth = imposeMonth, + ageUnit = "years", sex = FALSE, sexName = NULL, missingSexValue = NULL, diff --git a/R/addDemographicsQuery.R b/R/addDemographicsQuery.R index 8322dd6e..2e6005d6 100644 --- a/R/addDemographicsQuery.R +++ b/R/addDemographicsQuery.R @@ -17,41 +17,9 @@ #' Query to add demographic characteristics at a certain date #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addDemographics()`, except query is not computed to a table. #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the -#' demographics characteristics. -#' @param age TRUE or FALSE. If TRUE, age will be calculated relative to -#' indexDate. -#' @param ageMissingMonth Month of the year assigned to individuals with missing -#' month of birth. -#' @param ageName Age variable name. -#' @param ageMissingDay day of the month assigned to individuals -#' with missing day of birth. -#' @param ageImposeMonth TRUE or FALSE. Whether the month of the date of birth -#' will be considered as missing for all the individuals. -#' @param ageImposeDay TRUE or FALSE. Whether the day of the date of birth -#' will be considered as missing for all the individuals. -#' @param ageGroup if not NULL, a list of ageGroup vectors. -#' @param missingAgeGroupValue Value to include if missing age. -#' @param sex TRUE or FALSE. If TRUE, sex will be identified. -#' @param sexName Sex variable name. -#' @param missingSexValue Value to include if missing sex. -#' @param priorObservation TRUE or FALSE. If TRUE, days of between the start -#' of the current observation period and the indexDate will be calculated. -#' @param priorObservationName Prior observation variable name. -#' @param priorObservationType Whether to return a "date" or the number of -#' "days". -#' @param futureObservation TRUE or FALSE. If TRUE, days between the -#' indexDate and the end of the current observation period will be -#' calculated. -#' @param futureObservationName Future observation variable name. -#' @param futureObservationType Whether to return a "date" or the number of -#' "days". -#' @param dateOfBirth TRUE or FALSE, if true the date of birth will be return. -#' @param dateOfBirthName dateOfBirth column name. +#' @inheritParams addDemographics #' #' @return cohort table with the added demographic information columns. #' @export @@ -75,6 +43,7 @@ addDemographicsQuery <- function(x, ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", ageGroup = NULL, missingAgeGroupValue = "None", sex = TRUE, @@ -97,6 +66,7 @@ addDemographicsQuery <- function(x, ageMissingMonth = ageMissingMonth, ageImposeDay = ageImposeDay, ageImposeMonth = ageImposeMonth, + ageUnit = ageUnit, sex = sex, sexName = sexName, missingSexValue = missingSexValue, @@ -116,22 +86,9 @@ addDemographicsQuery <- function(x, #' Query to add the age of the individuals at a certain date #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addAge()`, except query is not computed to a table. #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the age. -#' @param ageName Name of the new column that contains age. -#' @param ageGroup List of age groups to be added. -#' @param ageMissingMonth Month of the year assigned to individuals with missing -#' month of birth. By default: 1. -#' @param ageMissingDay day of the month assigned to individuals with missing -#' day of birth. By default: 1. -#' @param ageImposeMonth Whether the month of the date of birth will be -#' considered as missing for all the individuals. -#' @param ageImposeDay Whether the day of the date of birth will be considered -#' as missing for all the individuals. -#' @param missingAgeGroupValue Value to include if missing age. +#' @inheritParams addDemographics #' #' @return tibble with the age column added. #' @export @@ -154,6 +111,7 @@ addAgeQuery <- function(x, ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", missingAgeGroupValue = "None") { x |> .addDemographicsQuery( @@ -165,6 +123,7 @@ addAgeQuery <- function(x, ageMissingMonth = ageMissingMonth, ageImposeDay = ageImposeDay, ageImposeMonth = ageImposeMonth, + ageUnit = ageUnit, missingAgeGroupValue = missingAgeGroupValue, sex = FALSE, priorObservation = FALSE, @@ -184,15 +143,9 @@ addAgeQuery <- function(x, #' certain date #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addFutureObservation()`, except query is not computed to a table. #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the future -#' observation. -#' @param futureObservationName name of the new column to be added. -#' @param futureObservationType Whether to return a "date" or the number of -#' "days". +#' @inheritParams addDemographics #' #' @return cohort table with added column containing future observation of the #' individuals. @@ -221,6 +174,7 @@ addFutureObservationQuery <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = FALSE, priorObservation = FALSE, futureObservation = TRUE, @@ -241,15 +195,9 @@ addFutureObservationQuery <- function(x, #' observation period at a certain date #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addPriorObservation()`, except query is not computed to a table. #' -#' @param x Table with individuals in the cdm. -#' @param indexDate Variable in x that contains the date to compute the prior -#' observation. -#' @param priorObservationName name of the new column to be added. -#' @param priorObservationType Whether to return a "date" or the number of -#' "days". +#' @inheritParams addDemographics #' #' @return cohort table with added column containing prior observation of the #' individuals. @@ -279,6 +227,7 @@ addPriorObservationQuery <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = FALSE, priorObservation = TRUE, priorObservationName = priorObservationName, @@ -298,12 +247,9 @@ addPriorObservationQuery <- function(x, #' Query to add the sex of the individuals #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addSex()`, except query is not computed to a table. #' -#' @param x Table with individuals in the cdm. -#' @param sexName name of the new column to be added. -#' @param missingSexValue Value to include if missing sex. +#' @inheritParams addDemographics #' #' @return table x with the added column with sex information. #' @@ -332,6 +278,7 @@ addSexQuery <- function(x, ageMissingMonth = NULL, ageImposeDay = FALSE, ageImposeMonth = FALSE, + ageUnit = "years", sex = TRUE, sexName = sexName, missingSexValue = missingSexValue, @@ -351,16 +298,9 @@ addSexQuery <- function(x, #' Query to add a column with the individual birth date #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addDateOfBirth()`, except query is not computed to a table. #' -#' @param x Table in the cdm that contains 'person_id' or 'subject_id'. -#' @param dateOfBirthName Name of the column to be added with the date of birth. -#' @param missingDay Day of the individuals with no or imposed day of birth. -#' @param missingMonth Month of the individuals with no or imposed month of -#' birth. -#' @param imposeDay Whether to impose day of birth. -#' @param imposeMonth Whether to impose month of birth. +#' @inheritParams addDateOfBirth #' #' @return The function returns the table x with an extra column that contains #' the date of birth. @@ -392,6 +332,7 @@ addDateOfBirthQuery <- function(x, ageMissingMonth = missingMonth, ageImposeDay = imposeDay, ageImposeMonth = imposeMonth, + ageUnit = "years", sex = FALSE, sexName = NULL, missingSexValue = NULL, @@ -417,6 +358,7 @@ addDateOfBirthQuery <- function(x, ageImposeMonth, ageImposeDay, ageGroup, + ageUnit, missingAgeGroupValue, sex, sexName, @@ -457,6 +399,7 @@ addDateOfBirthQuery <- function(x, missingSexValue <- validateMissingValue(missingSexValue, null = !sex, call = call) priorObservationType <- validateType(priorObservationType, null = !priorObservation, call = call) futureObservationType <- validateType(futureObservationType, null = !futureObservation, call = call) + omopgenerics::assertChoice(ageUnit, c("days", "months", "years"), length = 1, call = call) # if no new columns return x if (!(age | sex | priorObservation | futureObservation | dateOfBirth | !is.null(ageGroup))) { @@ -593,12 +536,7 @@ addDateOfBirthQuery <- function(x, if (!age) { ageName <- newCols[2] } - aQ <- "as.integer(floor( - ( - (clock::get_year(.data[['{indexDate}']]) * 10000 + clock::get_month(.data[['{indexDate}']]) * 100 + clock::get_day(.data[['{indexDate}']])) - - (clock::get_year(.data[['{dateOfBirthName}']]) * 10000 + clock::get_month(.data[['{dateOfBirthName}']]) * 100 + clock::get_day(.data[['{dateOfBirthName}']])) - ) / 10000 - ))" |> + aQ <- getAgeQuery(ageUnit) |> glue::glue() |> rlang::parse_exprs() |> rlang::set_names(ageName) @@ -652,6 +590,30 @@ addDateOfBirthQuery <- function(x, return(xnew) } +getAgeQuery <- function(ageUnit) { + if (ageUnit == "years") { + aQ <- "as.integer(floor( + ( + (clock::get_year(.data[['{indexDate}']]) * 10000 + clock::get_month(.data[['{indexDate}']]) * 100 + clock::get_day(.data[['{indexDate}']])) - + (clock::get_year(.data[['{dateOfBirthName}']]) * 10000 + clock::get_month(.data[['{dateOfBirthName}']]) * 100 + clock::get_day(.data[['{dateOfBirthName}']])) + ) / 10000 + ))" + } else if (ageUnit == "months") { + aQ <- "as.integer(floor( + ( + (clock::get_year(.data[['{indexDate}']]) * 1200 + clock::get_month(.data[['{indexDate}']]) * 100 + clock::get_day(.data[['{indexDate}']])) - + (clock::get_year(.data[['{dateOfBirthName}']]) * 1200 + clock::get_month(.data[['{dateOfBirthName}']]) * 100 + clock::get_day(.data[['{dateOfBirthName}']])) + ) / 100 + ))" + } else if (ageUnit == "days") { + aQ <- "as.integer(clock::date_count_between( + start = .data[['{dateOfBirthName}']], + end = .data[['{indexDate}']], + precision = 'day' + ))" + } + return(aQ) +} ageGroupQuery <- function(ageName, ageGroup, missingAgeGroupValue) { ageName <- paste0(".data[['", ageName, "']]") purrr::map_chr(ageGroup, \(ag) { @@ -679,7 +641,6 @@ ageGroupQuery <- function(ageName, ageGroup, missingAgeGroupValue) { #' observation period #' #' @description -#' `r lifecycle::badge("experimental")` #' Same as `addInObservation()`, except query is not computed to a table. #' #' @param x Table with individuals in the cdm. @@ -829,10 +790,3 @@ addInObservationQuery <- function(x, return(x) } - -## This function is never called -## Exists to suppress this NOTE: -## Namespace in Imports field not imported from: ‘lifecycle’ -lc <- function() { - lifecycle::badge("experimental") -} diff --git a/R/addTableIntersect.R b/R/addTableIntersect.R index 44b7198a..c9ed40bf 100644 --- a/R/addTableIntersect.R +++ b/R/addTableIntersect.R @@ -365,13 +365,13 @@ addTableIntersectField <- function(x, inObservation = TRUE, order = "first", allowDuplicates = FALSE, - nameStyle = "{table_name}_{extra_value}_{window_name}", + nameStyle = "{table_name}_{field}_{window_name}", name = NULL) { cdm <- omopgenerics::cdmReference(x) omopgenerics::assertCharacter(tableName) omopgenerics::validateCdmArgument(cdm = cdm, requiredTables = tableName) nameStyle <- gsub("\\{table_name\\}", tableName, nameStyle) - nameStyle <- gsub("\\{extra_value\\}", "\\{value\\}", nameStyle) + nameStyle <- gsub("\\{field\\}", "\\{value\\}", nameStyle) if (missing(order) & rlang::is_interactive()) { messageOrder(order) diff --git a/R/benchmarkPatientProfiles.R b/R/benchmarkPatientProfiles.R index 5c760db6..ae106263 100644 --- a/R/benchmarkPatientProfiles.R +++ b/R/benchmarkPatientProfiles.R @@ -81,6 +81,7 @@ benchmarkPatientProfiles <- function(cdm, ageMissingDay = 1L, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", ageGroup = vals[[3]], missingAgeGroupValue = "none", sex = vals[[2]], diff --git a/R/checks.R b/R/checks.R index e350c948..5623c3a7 100644 --- a/R/checks.R +++ b/R/checks.R @@ -393,7 +393,7 @@ validateAgeMissingDay <- function(ageMissingDay, null, call) { if (is.character(ageMissingDay)) { ageMissingDay <- as.numeric(ageMissingDay) } - omopgenerics::assertNumeric(ageMissingDay, integerish = TRUE, min = 1, max = 12, call = call) + omopgenerics::assertNumeric(ageMissingDay, integerish = TRUE, min = 1, max = 31, call = call) ageMissingDay <- as.integer(ageMissingDay) return(ageMissingDay) diff --git a/R/summariseResult.R b/R/summariseResult.R index 511b08dc..fe4d7e3a 100644 --- a/R/summariseResult.R +++ b/R/summariseResult.R @@ -682,11 +682,15 @@ summariseCounts <- function(table, functions, weights) { dplyr::left_join(dens, by = "den") # assign numerator + if (length(weights) == 0) { + functs <- functs |> + dplyr::mutate(num = estimatesFunc[gsub("percentage", "count", .data$estimate_name)]) + } else { + functs <- functs |> + dplyr::mutate(num = estimatesFuncWeights[gsub("percentage", "count", .data$estimate_name)]) + } + functs <- functs |> - dplyr::mutate(num = dplyr::case_when( - length(.env$weights) == 0 ~ estimatesFunc[gsub("percentage", "count", .data$estimate_name)], - length(.env$weights) != 0 ~ estimatesFuncWeights[gsub("percentage", "count", .data$estimate_name)] - )) |> dplyr::rowwise() |> dplyr::mutate(num = gsub( "\\(x", paste0("\\(.data[['", .data$variable_name, "']]"), .data$num diff --git a/_pkgdown.yml b/_pkgdown.yml index e32baff6..d0e48a12 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -22,6 +22,7 @@ reference: - addPriorObservation - addFutureObservation - addInObservation + - addBirthday - subtitle: Add multiple individual patient characteristics desc: Add a set of patient characteristics to a table in the OMOP Common Data Model - contents: diff --git a/man/addAge.Rd b/man/addAge.Rd index 08094135..9a324268 100644 --- a/man/addAge.Rd +++ b/man/addAge.Rd @@ -13,6 +13,7 @@ addAge( ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", missingAgeGroupValue = "None", name = NULL ) @@ -20,23 +21,26 @@ addAge( \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the age.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{ageName}{Name of the new column that contains age.} +\item{ageName}{Age variable name.} -\item{ageGroup}{List of age groups to be added.} +\item{ageGroup}{if not NULL, a list of ageGroup vectors.} \item{ageMissingMonth}{Month of the year assigned to individuals with missing -month of birth. By default: 1.} +month of birth.} -\item{ageMissingDay}{day of the month assigned to individuals with missing -day of birth. By default: 1.} +\item{ageMissingDay}{day of the month assigned to individuals +with missing day of birth.} -\item{ageImposeMonth}{Whether the month of the date of birth will be -considered as missing for all the individuals.} +\item{ageImposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} -\item{ageImposeDay}{Whether the day of the date of birth will be considered -as missing for all the individuals.} +\item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} + +\item{ageUnit}{Unit for age it can either be 'years', 'months' or 'days'.} \item{missingAgeGroupValue}{Value to include if missing age.} diff --git a/man/addAgeQuery.Rd b/man/addAgeQuery.Rd index ac7f438d..5d388423 100644 --- a/man/addAgeQuery.Rd +++ b/man/addAgeQuery.Rd @@ -13,29 +13,33 @@ addAgeQuery( ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", missingAgeGroupValue = "None" ) } \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the age.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{ageName}{Name of the new column that contains age.} +\item{ageName}{Age variable name.} -\item{ageGroup}{List of age groups to be added.} +\item{ageGroup}{if not NULL, a list of ageGroup vectors.} \item{ageMissingMonth}{Month of the year assigned to individuals with missing -month of birth. By default: 1.} +month of birth.} -\item{ageMissingDay}{day of the month assigned to individuals with missing -day of birth. By default: 1.} +\item{ageMissingDay}{day of the month assigned to individuals +with missing day of birth.} -\item{ageImposeMonth}{Whether the month of the date of birth will be -considered as missing for all the individuals.} +\item{ageImposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} -\item{ageImposeDay}{Whether the day of the date of birth will be considered -as missing for all the individuals.} +\item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} + +\item{ageUnit}{Unit for age it can either be 'years', 'months' or 'days'.} \item{missingAgeGroupValue}{Value to include if missing age.} } @@ -43,8 +47,7 @@ as missing for all the individuals.} tibble with the age column added. } \description{ -`r lifecycle::badge("experimental")` -Same as `addAge()`, except query is not computed to a table. +Same as \code{addAge()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addBirthday.Rd b/man/addBirthday.Rd new file mode 100644 index 00000000..d2fa324f --- /dev/null +++ b/man/addBirthday.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addBirthDay.R +\name{addBirthday} +\alias{addBirthday} +\title{Add the birth day of an individual to a table} +\usage{ +addBirthday( + x, + birthday = 0, + birthdayName = "birthday", + ageMissingMonth = 1L, + ageMissingDay = 1L, + ageImposeMonth = FALSE, + ageImposeDay = FALSE, + name = NULL +) +} +\arguments{ +\item{x}{Table with individuals in the cdm.} + +\item{birthday}{Number of birth day.} + +\item{birthdayName}{Birth day variable name.} + +\item{ageMissingMonth}{Month of the year assigned to individuals with missing +month of birth.} + +\item{ageMissingDay}{day of the month assigned to individuals +with missing day of birth.} + +\item{ageImposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} + +\item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} + +\item{name}{Name of the new table, if NULL a temporary table is returned.} +} +\value{ +The table with a new column containing the birth day. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +The function accounts for leap years and corrects the invalid dates to the +next valid date. +} +\examples{ +\donttest{ +library(PatientProfiles) +library(dplyr) + +cdm <- mockPatientProfiles(source = "duckdb") + +cdm$cohort1 |> + addBirthday() |> + glimpse() + +cdm$cohort1 |> + addBirthday(birthday = 5, birthdayName = "bithday_5th") |> + glimpse() +} + +} diff --git a/man/addBirthdayQuery.Rd b/man/addBirthdayQuery.Rd new file mode 100644 index 00000000..179b8095 --- /dev/null +++ b/man/addBirthdayQuery.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addBirthDay.R +\name{addBirthdayQuery} +\alias{addBirthdayQuery} +\title{Add the birth day of an individual to a table} +\usage{ +addBirthdayQuery( + x, + birthdayName = "birthday", + birthday = 0, + ageMissingMonth = 1, + ageMissingDay = 1, + ageImposeMonth = FALSE, + ageImposeDay = FALSE +) +} +\arguments{ +\item{x}{Table with individuals in the cdm.} + +\item{birthdayName}{Birth day variable name.} + +\item{birthday}{Number of birth day.} + +\item{ageMissingMonth}{Month of the year assigned to individuals with missing +month of birth.} + +\item{ageMissingDay}{day of the month assigned to individuals +with missing day of birth.} + +\item{ageImposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} + +\item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} +} +\value{ +The table with a query that add the new column containing the birth +day. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Same as \code{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. +} +\examples{ +\donttest{ +library(PatientProfiles) +library(dplyr) + +cdm <- mockPatientProfiles(source = "duckdb") + +cdm$cohort1 |> + addBirthdayQuery() |> + glimpse() + +cdm$cohort1 |> + addBirthdayQuery(birthday = 5) |> + glimpse() +} + +} diff --git a/man/addCohortIntersectField.Rd b/man/addCohortIntersectField.Rd new file mode 100644 index 00000000..4412d3fe --- /dev/null +++ b/man/addCohortIntersectField.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addCohortIntersect.R +\name{addCohortIntersectField} +\alias{addCohortIntersectField} +\title{It creates a column with the field of a desired intersection} +\usage{ +addCohortIntersectField( + 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 +) +} +\arguments{ +\item{x}{Table with individuals in the cdm.} + +\item{targetCohortTable}{name of the cohort that we want to check for overlap.} + +\item{field}{Column of interest in the targetCohort.} + +\item{targetCohortId}{vector of cohort definition ids to include.} + +\item{indexDate}{Variable in x that contains the date to compute the +intersection.} + +\item{censorDate}{whether to censor overlap events at a specific date +or a column date of x.} + +\item{targetDate}{Date of interest in the other cohort table. Either +cohort_start_date or cohort_end_date.} + +\item{order}{date to use if there are multiple records for an +individual during the window of interest. Either first or last.} + +\item{window}{Window of time to identify records relative to the indexDate. +Records outside of this time period will be ignored.} + +\item{nameStyle}{naming of the added column or columns, should include +required parameters.} + +\item{name}{Name of the new table, if NULL a temporary table is returned.} +} +\value{ +table with added columns with overlap information. +} +\description{ +It creates a column with the field of a desired intersection +} +\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" + ) + +} + +} diff --git a/man/addConceptIntersectField.Rd b/man/addConceptIntersectField.Rd index 64064afe..c04d21dd 100644 --- a/man/addConceptIntersectField.Rd +++ b/man/addConceptIntersectField.Rd @@ -45,7 +45,7 @@ will be considered.} \item{allowDuplicates}{Whether to allow multiple records with same conceptSet, person_id and targetDate. If switched to TRUE, the created new -columns (field) will be collapsed to a character vector separated by `;` to +columns (field) will be collapsed to a character vector separated by \verb{;} to account for multiple values per person.} \item{nameStyle}{naming of the added column or columns, should include @@ -54,7 +54,7 @@ required parameters.} \item{name}{Name of the new table, if NULL a temporary table is returned.} } \value{ -Table with the `field` value obtained from the intersection +Table with the \code{field} value obtained from the intersection } \description{ It adds a custom column (field) from the intersection with a certain table diff --git a/man/addConceptName.Rd b/man/addConceptName.Rd index 84718d2c..0234b01a 100644 --- a/man/addConceptName.Rd +++ b/man/addConceptName.Rd @@ -10,7 +10,7 @@ addConceptName(table, column = NULL, nameStyle = "{column}_name") \item{table}{cdm_table that contains column.} \item{column}{Column to add the concept names from. If NULL any column that -its name ends with `concept_id` will be used.} +its name ends with \code{concept_id} will be used.} \item{nameStyle}{Name of the new column.} } diff --git a/man/addDateOfBirth.Rd b/man/addDateOfBirth.Rd index b7dc2a4b..79dec889 100644 --- a/man/addDateOfBirth.Rd +++ b/man/addDateOfBirth.Rd @@ -15,18 +15,21 @@ addDateOfBirth( ) } \arguments{ -\item{x}{Table in the cdm that contains 'person_id' or 'subject_id'.} +\item{x}{Table with individuals in the cdm.} -\item{dateOfBirthName}{Name of the column to be added with the date of birth.} +\item{dateOfBirthName}{dateOfBirth column name.} -\item{missingDay}{Day of the individuals with no or imposed day of birth.} +\item{missingDay}{day of the month assigned to individuals +with missing day of birth.} -\item{missingMonth}{Month of the individuals with no or imposed month of -birth.} +\item{missingMonth}{Month of the year assigned to individuals with missing +month of birth.} -\item{imposeDay}{Whether to impose day of birth.} +\item{imposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} -\item{imposeMonth}{Whether to impose month of birth.} +\item{imposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} \item{name}{Name of the new table, if NULL a temporary table is returned.} } diff --git a/man/addDateOfBirthQuery.Rd b/man/addDateOfBirthQuery.Rd index 1886ba6d..1d93c1fe 100644 --- a/man/addDateOfBirthQuery.Rd +++ b/man/addDateOfBirthQuery.Rd @@ -14,26 +14,28 @@ addDateOfBirthQuery( ) } \arguments{ -\item{x}{Table in the cdm that contains 'person_id' or 'subject_id'.} +\item{x}{Table with individuals in the cdm.} -\item{dateOfBirthName}{Name of the column to be added with the date of birth.} +\item{dateOfBirthName}{dateOfBirth column name.} -\item{missingDay}{Day of the individuals with no or imposed day of birth.} +\item{missingDay}{day of the month assigned to individuals +with missing day of birth.} -\item{missingMonth}{Month of the individuals with no or imposed month of -birth.} +\item{missingMonth}{Month of the year assigned to individuals with missing +month of birth.} -\item{imposeDay}{Whether to impose day of birth.} +\item{imposeDay}{TRUE or FALSE. Whether the day of the date of birth +will be considered as missing for all the individuals.} -\item{imposeMonth}{Whether to impose month of birth.} +\item{imposeMonth}{TRUE or FALSE. Whether the month of the date of birth +will be considered as missing for all the individuals.} } \value{ The function returns the table x with an extra column that contains the date of birth. } \description{ -`r lifecycle::badge("experimental")` -Same as `addDateOfBirth()`, except query is not computed to a table. +Same as \code{addDateOfBirth()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addDeathDate.Rd b/man/addDeathDate.Rd index c25ed6ad..9bdc0985 100644 --- a/man/addDeathDate.Rd +++ b/man/addDeathDate.Rd @@ -3,7 +3,7 @@ \name{addDeathDate} \alias{addDeathDate} \title{Add date of death for individuals. Only death within the same observation -period than `indexDate` will be observed.} +period than \code{indexDate} will be observed.} \usage{ addDeathDate( x, @@ -32,7 +32,7 @@ table x with the added column with death information added. } \description{ Add date of death for individuals. Only death within the same observation -period than `indexDate` will be observed. +period than \code{indexDate} will be observed. } \examples{ \donttest{ diff --git a/man/addDeathDays.Rd b/man/addDeathDays.Rd index 1d3c1fc0..450ae738 100644 --- a/man/addDeathDays.Rd +++ b/man/addDeathDays.Rd @@ -3,7 +3,7 @@ \name{addDeathDays} \alias{addDeathDays} \title{Add days to death for individuals. Only death within the same observation -period than `indexDate` will be observed.} +period than \code{indexDate} will be observed.} \usage{ addDeathDays( x, @@ -32,7 +32,7 @@ table x with the added column with death information added. } \description{ Add days to death for individuals. Only death within the same observation -period than `indexDate` will be observed. +period than \code{indexDate} will be observed. } \examples{ \donttest{ diff --git a/man/addDeathFlag.Rd b/man/addDeathFlag.Rd index 742b7052..b956b911 100644 --- a/man/addDeathFlag.Rd +++ b/man/addDeathFlag.Rd @@ -3,7 +3,7 @@ \name{addDeathFlag} \alias{addDeathFlag} \title{Add flag for death for individuals. Only death within the same observation -period than `indexDate` will be observed.} +period than \code{indexDate} will be observed.} \usage{ addDeathFlag( x, @@ -32,7 +32,7 @@ table x with the added column with death information added. } \description{ Add flag for death for individuals. Only death within the same observation -period than `indexDate` will be observed. +period than \code{indexDate} will be observed. } \examples{ \donttest{ diff --git a/man/addDemographics.Rd b/man/addDemographics.Rd index 7ffe4742..33a47b17 100644 --- a/man/addDemographics.Rd +++ b/man/addDemographics.Rd @@ -13,6 +13,7 @@ addDemographics( ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", ageGroup = NULL, missingAgeGroupValue = "None", sex = TRUE, @@ -52,6 +53,8 @@ will be considered as missing for all the individuals.} \item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth will be considered as missing for all the individuals.} +\item{ageUnit}{Unit for age it can either be 'years', 'months' or 'days'.} + \item{ageGroup}{if not NULL, a list of ageGroup vectors.} \item{missingAgeGroupValue}{Value to include if missing age.} diff --git a/man/addDemographicsQuery.Rd b/man/addDemographicsQuery.Rd index 2603a00a..50a4ccdf 100644 --- a/man/addDemographicsQuery.Rd +++ b/man/addDemographicsQuery.Rd @@ -13,6 +13,7 @@ addDemographicsQuery( ageMissingDay = 1, ageImposeMonth = FALSE, ageImposeDay = FALSE, + ageUnit = "years", ageGroup = NULL, missingAgeGroupValue = "None", sex = TRUE, @@ -51,6 +52,8 @@ will be considered as missing for all the individuals.} \item{ageImposeDay}{TRUE or FALSE. Whether the day of the date of birth will be considered as missing for all the individuals.} +\item{ageUnit}{Unit for age it can either be 'years', 'months' or 'days'.} + \item{ageGroup}{if not NULL, a list of ageGroup vectors.} \item{missingAgeGroupValue}{Value to include if missing age.} @@ -86,8 +89,7 @@ calculated.} cohort table with the added demographic information columns. } \description{ -`r lifecycle::badge("experimental")` -Same as `addDemographics()`, except query is not computed to a table. +Same as \code{addDemographics()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addFutureObservation.Rd b/man/addFutureObservation.Rd index 47338a43..75509dfe 100644 --- a/man/addFutureObservation.Rd +++ b/man/addFutureObservation.Rd @@ -16,10 +16,10 @@ addFutureObservation( \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the future -observation.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{futureObservationName}{name of the new column to be added.} +\item{futureObservationName}{Future observation variable name.} \item{futureObservationType}{Whether to return a "date" or the number of "days".} diff --git a/man/addFutureObservationQuery.Rd b/man/addFutureObservationQuery.Rd index 0ccd7dca..f13572a4 100644 --- a/man/addFutureObservationQuery.Rd +++ b/man/addFutureObservationQuery.Rd @@ -15,10 +15,10 @@ addFutureObservationQuery( \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the future -observation.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{futureObservationName}{name of the new column to be added.} +\item{futureObservationName}{Future observation variable name.} \item{futureObservationType}{Whether to return a "date" or the number of "days".} @@ -28,8 +28,7 @@ cohort table with added column containing future observation of the individuals. } \description{ -`r lifecycle::badge("experimental")` -Same as `addFutureObservation()`, except query is not computed to a table. +Same as \code{addFutureObservation()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addInObservationQuery.Rd b/man/addInObservationQuery.Rd index 7deaf4eb..cc81da99 100644 --- a/man/addInObservationQuery.Rd +++ b/man/addInObservationQuery.Rd @@ -31,8 +31,7 @@ cohort table with the added numeric column assessing observation (1 in observation, 0 not in observation). } \description{ -`r lifecycle::badge("experimental")` -Same as `addInObservation()`, except query is not computed to a table. +Same as \code{addInObservation()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addPriorObservation.Rd b/man/addPriorObservation.Rd index 22ffece3..322acbb6 100644 --- a/man/addPriorObservation.Rd +++ b/man/addPriorObservation.Rd @@ -16,10 +16,10 @@ addPriorObservation( \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the prior -observation.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{priorObservationName}{name of the new column to be added.} +\item{priorObservationName}{Prior observation variable name.} \item{priorObservationType}{Whether to return a "date" or the number of "days".} diff --git a/man/addPriorObservationQuery.Rd b/man/addPriorObservationQuery.Rd index 8fd865f1..3e66703e 100644 --- a/man/addPriorObservationQuery.Rd +++ b/man/addPriorObservationQuery.Rd @@ -15,10 +15,10 @@ addPriorObservationQuery( \arguments{ \item{x}{Table with individuals in the cdm.} -\item{indexDate}{Variable in x that contains the date to compute the prior -observation.} +\item{indexDate}{Variable in x that contains the date to compute the +demographics characteristics.} -\item{priorObservationName}{name of the new column to be added.} +\item{priorObservationName}{Prior observation variable name.} \item{priorObservationType}{Whether to return a "date" or the number of "days".} @@ -28,8 +28,7 @@ cohort table with added column containing prior observation of the individuals. } \description{ -`r lifecycle::badge("experimental")` -Same as `addPriorObservation()`, except query is not computed to a table. +Same as \code{addPriorObservation()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addSex.Rd b/man/addSex.Rd index d1fa1554..19d4244e 100644 --- a/man/addSex.Rd +++ b/man/addSex.Rd @@ -9,7 +9,7 @@ addSex(x, sexName = "sex", missingSexValue = "None", name = NULL) \arguments{ \item{x}{Table with individuals in the cdm.} -\item{sexName}{name of the new column to be added.} +\item{sexName}{Sex variable name.} \item{missingSexValue}{Value to include if missing sex.} diff --git a/man/addSexQuery.Rd b/man/addSexQuery.Rd index 469b497d..4f4fd383 100644 --- a/man/addSexQuery.Rd +++ b/man/addSexQuery.Rd @@ -9,7 +9,7 @@ addSexQuery(x, sexName = "sex", missingSexValue = "None") \arguments{ \item{x}{Table with individuals in the cdm.} -\item{sexName}{name of the new column to be added.} +\item{sexName}{Sex variable name.} \item{missingSexValue}{Value to include if missing sex.} } @@ -17,8 +17,7 @@ addSexQuery(x, sexName = "sex", missingSexValue = "None") table x with the added column with sex information. } \description{ -`r lifecycle::badge("experimental")` -Same as `addSex()`, except query is not computed to a table. +Same as \code{addSex()}, except query is not computed to a table. } \examples{ \donttest{ diff --git a/man/addTableIntersectField.Rd b/man/addTableIntersectField.Rd index 634af516..f901a3b3 100644 --- a/man/addTableIntersectField.Rd +++ b/man/addTableIntersectField.Rd @@ -17,7 +17,7 @@ addTableIntersectField( inObservation = TRUE, order = "first", allowDuplicates = FALSE, - nameStyle = "{table_name}_{extra_value}_{window_name}", + nameStyle = "{table_name}_{field}_{window_name}", name = NULL ) } @@ -51,7 +51,7 @@ required for date and days options).} \item{allowDuplicates}{Whether to allow multiple records with same conceptSet, person_id and targetDate. If switched to TRUE, the created new -columns (field) will be collapsed to a character vector separated by `;` to +columns (field) will be collapsed to a character vector separated by \verb{;} to account for multiple values per person.} \item{nameStyle}{naming of the added column or columns, should include diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 00000000..b61c57c3 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 00000000..5d88fc2c --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1,21 @@ + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 00000000..9bf21e76 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1,29 @@ + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 00000000..db8d757f --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1,21 @@ + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/filterCohortId.Rd b/man/filterCohortId.Rd index 56fe76fc..58fe95a1 100644 --- a/man/filterCohortId.Rd +++ b/man/filterCohortId.Rd @@ -9,12 +9,12 @@ functions of other packages.} filterCohortId(cohort, cohortId = NULL) } \arguments{ -\item{cohort}{A `cohort_table` object.} +\item{cohort}{A \code{cohort_table} object.} \item{cohortId}{A vector with cohort ids.} } \value{ -A `cohort_table` object. +A \code{cohort_table} object. } \description{ Filter a cohort according to cohort_definition_id column, the result is not diff --git a/man/filterInObservation.Rd b/man/filterInObservation.Rd index 0cafdcaf..e3ae739c 100644 --- a/man/filterInObservation.Rd +++ b/man/filterInObservation.Rd @@ -2,21 +2,21 @@ % Please edit documentation in R/filterInObservation.R \name{filterInObservation} \alias{filterInObservation} -\title{Filter the rows of a `cdm_table` to the ones in observation that `indexDate` +\title{Filter the rows of a \code{cdm_table} to the ones in observation that \code{indexDate} is in observation.} \usage{ filterInObservation(x, indexDate) } \arguments{ -\item{x}{A `cdm_table` object.} +\item{x}{A \code{cdm_table} object.} \item{indexDate}{Name of a column of x that is a date.} } \value{ -A `cdm_table` that is a subset of the original table. +A \code{cdm_table} that is a subset of the original table. } \description{ -Filter the rows of a `cdm_table` to the ones in observation that `indexDate` +Filter the rows of a \code{cdm_table} to the ones in observation that \code{indexDate} is in observation. } \examples{ diff --git a/tests/testthat/test-addBirthDay.R b/tests/testthat/test-addBirthDay.R new file mode 100644 index 00000000..98f997ed --- /dev/null +++ b/tests/testthat/test-addBirthDay.R @@ -0,0 +1,149 @@ +test_that("addBirthday functions", { + skip_on_cran() + cdm <- omock::mockCdmFromTables(tables = list( + person = dplyr::tibble( + person_id = 1:5L, + year_of_birth = c(1990L, 1991L, 1992L, 1993L, 1994L), + month_of_birth = c(1L, NA, 2L, 2L, 4L), + day_of_birth = c(30L, 29L, 29L, NA, 1L), + gender_concept_id = 0L + ), + cohort = dplyr::tibble( + cohort_definition_id = 1L, + subject_id = 1:5L, + cohort_start_date = as.Date("2010-01-01"), + cohort_end_date = cohort_start_date + ), + observation_period = dplyr::tibble( + observation_period_id = 1:5L, + person_id = 1:5L, + observation_period_start_date = as.Date("2000-01-01"), + observation_period_end_date = as.Date("2020-01-01") + ) + )) |> + copyCdm() + + expect_no_error( + x <- cdm$cohort |> + addBirthday() |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1990-01-30", "1991-01-29", "1992-02-29", "1993-02-01", "1994-04-01")) + ) + + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 1) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1991-01-30", "1992-01-29", "1993-03-01", "1994-02-01", "1995-04-01")) + ) + + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 2) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1992-01-30", "1993-01-29", "1994-03-01", "1995-02-01", "1996-04-01")) + ) + + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 3) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1993-01-30", "1994-01-29", "1995-03-01", "1996-02-01", "1997-04-01")) + ) + + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 4) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1994-01-30", "1995-01-29", "1996-02-29", "1997-02-01", "1998-04-01")) + ) + + # missing dates + expect_no_error( + x <- cdm$cohort |> + addBirthday(ageMissingMonth = 2, ageMissingDay = 29) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1990-01-30", "1991-03-01", "1992-02-29", "1993-03-01", "1994-04-01")) + ) + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 1, ageMissingMonth = 2, ageMissingDay = 29) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1991-01-30", "1992-02-29", "1993-03-01", "1994-03-01", "1995-04-01")) + ) + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = -1, ageMissingMonth = 2, ageMissingDay = 29) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1989-01-30", "1990-03-01", "1991-03-01", "1992-02-29", "1993-04-01")) + ) + + # impose days + expect_no_error( + x <- cdm$cohort |> + addBirthday(birthday = 2, ageMissingMonth = 2, ageMissingDay = 29, ageImposeMonth = TRUE, ageImposeDay = TRUE) |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + expect_identical( + x$birthday, + as.Date(c("1992-02-29", "1993-03-01", "1994-03-01", "1995-03-01", "1996-02-29")) + ) + + # name + expect_no_error( + x <- cdm$cohort |> + addBirthday(name = "new_table") + ) + expect_true("new_table" %in% omopgenerics::listSourceTables(cdm = cdm)) + + # query + ls <- omopgenerics::listSourceTables(cdm = cdm) + expect_no_error( + xx <- cdm$cohort |> + addBirthdayQuery() + ) + expect_identical(ls, omopgenerics::listSourceTables(cdm = cdm)) + expect_identical( + x |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id), + xx |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) + ) + + dropCreatedTables(cdm = cdm) +}) diff --git a/tests/testthat/test-addCohortIntersect.R b/tests/testthat/test-addCohortIntersect.R index 537f5f7c..161d44e9 100644 --- a/tests/testthat/test-addCohortIntersect.R +++ b/tests/testthat/test-addCohortIntersect.R @@ -995,3 +995,53 @@ test_that("duplicated measurment results", { dropCreatedTables(cdm = cdm) }) + +test_that("test addCohortIntersectField", { + skip_on_cran() + cdm <- omock::mockCdmFromTables(tables = list( + cohort1 = dplyr::tibble( + cohort_definition_id = 1L, + subject_id = 1L, + cohort_start_date = as.Date("2005-01-01"), + cohort_end_date = as.Date("2005-01-01") + ), + cohort2 = dplyr::tibble( + cohort_definition_id = 1L, + subject_id = 1L, + cohort_start_date = as.Date(c("2000-01-01", "2010-01-01")), + cohort_end_date = as.Date(c("2000-01-01", "2010-01-01")), + test = c("A", "B") + ) + )) |> + copyCdm() + + expect_no_error( + x <- cdm$cohort1 |> + addCohortIntersectField(targetCohortTable = "cohort2", field = "test", window = c(0, Inf)) |> + dplyr::collect() + ) + expect_identical(x$cohort_1_test_0_to_inf, "B") + + expect_no_error( + x <- cdm$cohort1 |> + addCohortIntersectField(targetCohortTable = "cohort2", field = "test", window = c(-Inf, 0)) |> + dplyr::collect() + ) + expect_identical(x$cohort_1_test_minf_to_0, "A") + + expect_no_error( + x <- cdm$cohort1 |> + addCohortIntersectField(targetCohortTable = "cohort2", field = "test", window = c(0, 0)) |> + dplyr::collect() + ) + expect_identical(x$cohort_1_test_0_to_0, NA_character_) + + expect_no_error( + x <- cdm$cohort1 |> + addCohortIntersectField(targetCohortTable = "cohort2", field = "test", window = c(-Inf, Inf), order = "last", nameStyle = "new_col") |> + dplyr::collect() + ) + expect_identical(x$new_col, "B") + + dropCreatedTables(cdm = cdm) +}) diff --git a/tests/testthat/test-addDemographics.R b/tests/testthat/test-addDemographics.R index 82bbd5ac..f96ad7c3 100644 --- a/tests/testthat/test-addDemographics.R +++ b/tests/testthat/test-addDemographics.R @@ -1435,3 +1435,64 @@ test_that("test query functions", { dropCreatedTables(cdm = cdm) }) + +test_that("test ageUnit", { + skip_on_cran() + person <- dplyr::tribble( + ~person_id, ~year_of_birth, ~month_of_birth, ~day_of_birth, + 1L, 2015L, 4L, 30L, + 2L, 2015L, 3L, 31L, + 3L, 2015L, 5L, 31L, + 4L, 2015L, 3L, 31L, + 5L, 2015L, 3L, 30L, + 5L, 2015L, 3L, 29L, + ) |> + dplyr::mutate(gender_concept_id = 0L) + cohort <- dplyr::tibble( + cohort_definition_id = 1L, + subject_id = 1:5L, + cohort_start_date = as.Date("2020-04-30"), + cohort_end_date = cohort_start_date + ) + op <- dplyr::tibble( + observation_period_id = 1:5L, + person_id = 1:5L, + observation_period_start_date = as.Date("2016-01-01"), + observation_period_end_date = as.Date("2022-01-01") + ) + cdm <- omock::mockCdmFromTables(tables = list( + person = person, + cohort = cohort, + observation_period = op + )) |> + copyCdm() + + # years + expect_no_error( + x <- cdm$cohort |> + addAge(ageUnit = "years") |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) |> + dplyr::pull("age") + ) + + # months + expect_no_error( + x <- cdm$cohort |> + addDemographicsQuery(ageUnit = "months") |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) |> + dplyr::pull("age") + ) + + # days + expect_no_error( + x <- cdm$cohort |> + addDemographics(ageUnit = "days") |> + dplyr::collect() |> + dplyr::arrange(.data$subject_id) |> + dplyr::pull("age") + ) + + dropCreatedTables(cdm = cdm) +})