Merge branch 'master' into age_calculate_fix

Author: Tina815

DESCRIPTION

@@ -13,7 +13,7 @@ Authors@R: c(
     person("Graeme", "Gowans", , "Graeme.Gowans@phs.scot", role = "aut"),
     person("Alice", "Byers", role = "ctb"),
     person("Alan", "Yeung", , "Alan.Yeung@phs.scot", role = "ctb"),
-    person("James", "McMahon", , "James.McMahon@phs.scot", role = "aut",
+    person("James", "Hayes", , "James.Hayes2@phs.scot", role = "aut",
            comment = c(ORCID = "0000-0002-5380-2029")),
     person("Nicolaos", "Christofidis", , "nicolaos.christofidis@phs.scot", role = "aut")
   )

R/age_from_chi.R

@@ -0,0 +1,190 @@
+#' @title Extract age from the CHI number
+#'
+#' @description `age_from_chi` takes a CHI number or a vector of CHI numbers
+#' and returns the age as implied by the CHI number(s). If the Date of Birth
+#' (DoB) is ambiguous it will return NA. It uses [dob_from_chi()].
+#'
+#' @param chi_number a CHI number or a vector of CHI numbers with `character`
+#' class.
+#' @param ref_date calculate the age at this date, default is to use
+#' `Sys.Date()` i.e. today.
+#' @param min_age,max_age optional min and/or max dates that the DoB could take
+#' as the century needs to be guessed.
+#' Must be either length 1 for a 'fixed' age or the same length as `chi_number`
+#' for an age per CHI number.
+#' `min_age` can be age based on common sense in the dataset, whilst `max_age`
+#' can be age when an event happens such as the age at discharge.
+#' @param chi_check logical, optionally skip checking the CHI for validity which
+#' will be faster but should only be used if you have previously checked the
+#' CHI(s), the default (TRUE) will to check the CHI numbers.
+#'
+#' @return an integer vector of ages in years truncated to the nearest year.
+#' It will be the same length as `chi_number`.
+#' @export
+#'
+#' @examples
+#' age_from_chi("0101336489")
+#'
+#' library(tibble)
+#' library(dplyr)
+#' data <- tibble(chi = c(
+#'   "0101336489",
+#'   "0101405073",
+#'   "0101625707"
+#' ), dis_date = as.Date(c(
+#'   "1950-01-01",
+#'   "2000-01-01",
+#'   "2020-01-01"
+#' )))
+#'
+#' data %>%
+#'   mutate(chi_age = age_from_chi(chi))
+#'
+#' data %>%
+#'   mutate(chi_age = age_from_chi(chi, min_age = 18, max_age = 65))
+#'
+#' data %>%
+#'   mutate(chi_age = age_from_chi(chi,
+#'     ref_date = dis_date
+#'   ))
+age_from_chi <- function(
+    chi_number,
+    ref_date = NULL,
+    min_age = 0L,
+    max_age = NULL,
+    chi_check = TRUE) {
+  # Do type checking on the params
+  if (!inherits(chi_number, "character")) {
+    cli::cli_abort(
+      "{.arg chi_number} must be a {.cls character} vector, not a {.cls {class(chi_number)}} vector."
+    )
+  }
+
+  if (!is.null(ref_date) && !inherits(ref_date, c("Date", "POSIXct"))) {
+    cli::cli_abort(
+      "{.arg ref_date} must be a {.cls Date} or {.cls POSIXct} vector, not a {.cls {class(ref_date)}} vector."
+    )
+  }
+
+  if (!inherits(min_age, c("integer", "numeric"))) {
+    cli::cli_abort(
+      "{.arg min_age} must be a {.cls integer} vector, not a {.cls {class(min_age)}} vector."
+    )
+  }
+
+  if (!is.null(max_age) && !inherits(max_age, c("integer", "numeric"))) {
+    cli::cli_abort(
+      "{.arg max_age} must be a {.cls integer} vector, not a {.cls {class(max_age)}} vector."
+    )
+  }
+
+  # Handle NULL and NA values in ref_date
+  if (is.null(ref_date)) {
+    ref_date <- Sys.Date()
+  } else if (anyNA(ref_date)) {
+    # If ref_date is a vector, fill in today's date where it's missing
+    ref_date[is.na(ref_date)] <- Sys.Date()
+  }
+
+  n_chis <- length(chi_number)
+
+  if (length(ref_date) != 1L) {
+    if (n_chis != 1L && n_chis != length(ref_date)) {
+      cli::cli_abort(
+        "{.arg ref_date} must be size {length(chi_number)} (the same as {.arg chi_number}) not {length(ref_date)}."
+      )
+    } else if (n_chis == 1L) {
+      cli::cli_abort(
+        "{.arg ref_date} must be size 1 (the same as {.arg chi_number}) not {length(ref_date)}."
+      )
+    }
+  }
+  # Ensure ref_date is replicated if length 1
+  if (length(ref_date) == 1L && length(chi_number) > 1L) {
+    ref_date <- rep(ref_date, length(chi_number))
+  }
+
+  # Handle NULL and NA values in max_age
+  if (is.null(max_age)) {
+    # If max_age is NULL, set it to a very large number (e.g., age from 1900-01-01)
+    # This corresponds to the default min_date behaviour in dob_from_chi
+    max_age <- age_calculate(as.Date("1900-01-01"), ref_date)
+  } else if (anyNA(max_age)) {
+    # Ensure max_age is replicated if length 1
+    if (length(max_age) == 1L && length(chi_number) > 1L) {
+      max_age <- rep(max_age, length(chi_number))
+    }
+
+    # If max_age is a vector, fill in the age from 1900-01-01 where it's missing
+    max_age[is.na(max_age)] <- age_calculate(
+      as.Date("1900-01-01"),
+      ref_date[is.na(max_age)]
+    )
+  }
+
+  if (length(max_age) != 1L) {
+    if (n_chis != 1L && n_chis != length(max_age)) {
+      cli::cli_abort(
+        "{.arg max_age} must be size {length(chi_number)} (the same as {.arg chi_number}) not {length(max_age)}."
+      )
+    } else if (n_chis == 1L) {
+      cli::cli_abort(
+        "{.arg max_age} must be size 1 (the same as {.arg chi_number}) not {length(max_age)}."
+      )
+    }
+  }
+
+  if (length(min_age) != 1L) {
+    if (n_chis != 1L && n_chis != length(min_age)) {
+      cli::cli_abort(
+        "{.arg min_age} must be size {length(chi_number)} (the same as {.arg chi_number}) not {length(min_age)}."
+      )
+    } else if (n_chis == 1L) {
+      cli::cli_abort(
+        "{.arg min_age} must be size 1 (the same as {.arg chi_number}) not {length(min_age)}."
+      )
+    }
+  }
+
+  # Handle NA values in min_age
+  # If min_age is a vector, fill in 0 where it's missing
+  if (anyNA(min_age)) {
+    min_age[is.na(min_age)] <- 0L
+  }
+
+  # min and max ages are in a reasonable range
+  if (any(min_age < 0L)) {
+    cli::cli_abort("{.arg min_age} must be a positive integer.")
+  }
+
+  # Ensure min_age is replicated if length 1
+  if (length(min_age) == 1L && length(chi_number) > 1L) {
+    min_age <- rep(min_age, length(chi_number))
+  }
+
+  # Check max_age vs min_age after handling NAs
+  if (any(max_age < min_age)) {
+    cli::cli_abort(
+      "{.arg max_age}, must always be greater than or equal to {.arg min_age}."
+    )
+  }
+
+  # Convert age ranges to date ranges relative to the reference date
+  # NA values in ref_date, min_age, or max_age will propagate NA correctly here
+  max_date.age <- ref_date - lubridate::years(min_age)
+  min_date.age <- ref_date - lubridate::years(max_age)
+
+  # Call dob_from_chi with the calculated date ranges
+  guess_dob <- dob_from_chi(
+    chi_number = chi_number,
+    min_date = min_date.age,
+    max_date = max_date.age,
+    chi_check = chi_check
+  )
+
+  # Calculate age from the guessed date of birth and reference date
+  # NA values in guess_dob or ref_date will result in NA age
+  guess_age <- age_calculate(guess_dob, ref_date)
+
+  return(guess_age)
+}