1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-10 15:01:54 +02:00

styled, unit test fix

This commit is contained in:
2022-08-28 10:31:50 +02:00
parent 4cb1db4554
commit 4d050aef7c
147 changed files with 10897 additions and 8169 deletions

74
R/age.R
View File

@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@ -32,7 +32,7 @@
#' @param na.rm a [logical] to indicate whether missing values should be removed
#' @param ... arguments passed on to [as.POSIXlt()], such as `origin`
#' @details Ages below 0 will be returned as `NA` with a warning. Ages above 120 will only give a warning.
#'
#'
#' This function vectorises over both `x` and `reference`, meaning that either can have a length of 1 while the other argument has a larger length.
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
#' @seealso To split ages into groups, use the [age_groups()] function.
@ -40,13 +40,13 @@
#' @examples
#' # 10 random pre-Y2K birth dates
#' df <- data.frame(birth_date = as.Date("2000-01-01") - runif(10) * 25000)
#'
#'
#' # add ages
#' df$age <- age(df$birth_date)
#'
#'
#' # add exact ages
#' df$age_exact <- age(df$birth_date, exact = TRUE)
#'
#'
#' # add age at millenium switch
#' df$age_at_y2k <- age(df$birth_date, "2000-01-01")
#'
@ -56,7 +56,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
meet_criteria(reference, allow_class = c("character", "Date", "POSIXt"))
meet_criteria(exact, allow_class = "logical", has_length = 1)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (length(x) != length(reference)) {
if (length(x) == 1) {
x <- rep(x, length(reference))
@ -68,26 +68,32 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
}
x <- as.POSIXlt(x, ...)
reference <- as.POSIXlt(reference, ...)
# from https://stackoverflow.com/a/25450756/4575331
years_gap <- reference$year - x$year
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1),
as.integer(years_gap))
as.integer(years_gap - 1),
as.integer(years_gap)
)
# add decimals
if (exact == TRUE) {
# get dates of `x` when `x` would have the year of `reference`
x_in_reference_year <- as.POSIXlt(paste0(format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")),
format = "%Y-%m-%d")
x_in_reference_year <- as.POSIXlt(paste0(
format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")
),
format = "%Y-%m-%d"
)
# get differences in days
n_days_x_rest <- as.double(difftime(as.Date(reference),
as.Date(x_in_reference_year),
units = "days"))
n_days_x_rest <- as.double(difftime(as.Date(reference),
as.Date(x_in_reference_year),
units = "days"
))
# get numbers of days the years of `reference` has for a reliable denominator
n_days_reference_year <- as.POSIXlt(paste0(format(as.Date(reference), "%Y"), "-12-31"),
format = "%Y-%m-%d")$yday + 1
format = "%Y-%m-%d"
)$yday + 1
# add decimal parts of year
mod <- n_days_x_rest / n_days_reference_year
# negative mods are cases where `x_in_reference_year` > `reference` - so 'add' a year
@ -95,7 +101,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
# and finally add to ages
ages <- ages + mod
}
if (any(ages < 0, na.rm = TRUE)) {
ages[!is.na(ages) & ages < 0] <- NA
warning_("in `age()`: NAs introduced for ages below 0.")
@ -103,11 +109,11 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
if (any(ages > 120, na.rm = TRUE)) {
warning_("in `age()`: some ages are above 120.")
}
if (isTRUE(na.rm)) {
ages <- ages[!is.na(ages)]
}
if (exact == TRUE) {
as.double(ages)
} else {
@ -122,7 +128,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' @param split_at values to split `x` at, defaults to age groups 0-11, 12-24, 25-54, 55-74 and 75+. See *Details*.
#' @param na.rm a [logical] to indicate whether missing values should be removed
#' @details To split ages, the input for the `split_at` argument can be:
#'
#'
#' * A [numeric] vector. A value of e.g. `c(10, 20)` will split `x` on 0-9, 10-19 and 20+. A value of only `50` will split `x` on 0-49 and 50+.
#' The default is to split on young children (0-11), youth (12-24), young adults (25-54), middle-aged adults (55-74) and elderly (75+).
#' * A character:
@ -163,17 +169,19 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' filter(mo == as.mo("Escherichia coli")) %>%
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",
#' title = "Ciprofloxacin resistance per age group")
#' ggplot_rsi(
#' x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",
#' title = "Ciprofloxacin resistance per age group"
#' )
#' }
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
meet_criteria(x, allow_class = c("numeric", "integer"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning_("in `age_groups()`: NAs introduced for ages below 0.")
@ -183,7 +191,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
if (split_at %like% "^(child|kid|junior)") {
split_at <- c(0, 1, 2, 4, 6, 13, 18)
} else if (split_at %like% "^(elder|senior)") {
split_at <- c(65, 75, 85)
split_at <- c(65, 75, 85)
} else if (split_at %like% "^five") {
split_at <- 1:20 * 5
} else if (split_at %like% "^ten") {
@ -197,7 +205,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
}
split_at <- split_at[!is.na(split_at)]
stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
# turn input values to 'split_at' indices
y <- x
lbls <- split_at
@ -206,15 +214,15 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# create labels
lbls[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
}
# last category
lbls[length(lbls)] <- paste0(split_at[length(split_at)], "+")
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
if (isTRUE(na.rm)) {
agegroups <- agegroups[!is.na(agegroups)]
}
agegroups
}