(v3.0.0.9011) allow names for age_groups()

R/aa_helper_functions.R

@@ -519,7 +519,7 @@ word_wrap <- function(...,
     )
     msg <- paste0(parts, collapse = "`")
   }
-  msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg)
+  msg <- gsub("`(.+?)`", font_grey_bg("`\\1`"), msg)
 
   # clean introduced whitespace in between fullstops
   msg <- gsub("[.] +[.]", "..", msg)

R/age.R

@@ -128,9 +128,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
 
 #' Split Ages into Age Groups
 #'
-#' Split ages into age groups defined by the `split` argument. This allows for easier demographic (antimicrobial resistance) analysis.
+#' Split ages into age groups defined by the `split` argument. This allows for easier demographic (antimicrobial resistance) analysis. The function returns an ordered [factor].
 #' @param x Age, e.g. calculated with [age()].
 #' @param split_at Values to split `x` at - the default is age groups 0-11, 12-24, 25-54, 55-74 and 75+. See *Details*.
+#' @param names Optional names to be given to the various age groups.
 #' @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:
 #'
@@ -152,6 +153,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
 #'
 #' # split into 0-19, 20-49 and 50+
 #' age_groups(ages, c(20, 50))
+#' age_groups(ages, c(20, 50), names = c("Under 20 years", "20 to 50 years", "Over 50 years"))
 #'
 #' # split into groups of ten years
 #' age_groups(ages, 1:10 * 10)
@@ -181,9 +183,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
 #'     )
 #' }
 #' }
-age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
+age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, 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(names, allow_class = "character", allow_NULL = TRUE)
   meet_criteria(na.rm, allow_class = "logical", has_length = 1)
 
   if (any(x < 0, na.rm = TRUE)) {
@@ -224,6 +227,11 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
 
   agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
 
+  if (!is.null(names)) {
+    stop_ifnot(length(names) == length(levels(agegroups)), "`names` must have the same length as the number of age groups (", length(levels(agegroups)), ").")
+    levels(agegroups) <- names
+  }
+
   if (isTRUE(na.rm)) {
     agegroups <- agegroups[!is.na(agegroups)]
   }

R/ggplot_sir.R

@@ -206,7 +206,7 @@ ggplot_sir <- function(data,
   meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
   language <- validate_language(language)
   meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
-  meet_criteria(colours, allow_class = c("character", "logical"))
+  meet_criteria(colours, allow_class = c("character", "logical"), allow_NULL = TRUE)
   meet_criteria(datalabels, allow_class = "logical", has_length = 1)
   meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
   meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
@@ -246,7 +246,7 @@ ggplot_sir <- function(data,
     ) +
     theme_sir()
 
-  if (fill == "interpretation") {
+  if (fill == "interpretation" && !is.null(colours) && !isFALSE(colours)) {
     p <- suppressWarnings(p + scale_sir_colours(aesthetics = "fill", colours = colours))
   }
 

R/tidymodels.R

@@ -19,56 +19,59 @@
 #' @keywords internal
 #' @export
 #' @examples
-#' library(tidymodels)
+#' if (require("tidymodels")) {
 #'
-#' # The below approach formed the basis for this paper: DOI 10.3389/fmicb.2025.1582703
-#' # Presence of ESBL genes was predicted based on raw MIC values.
+#'   # The below approach formed the basis for this paper: DOI 10.3389/fmicb.2025.1582703
+#'   # Presence of ESBL genes was predicted based on raw MIC values.
 #'
 #'
-#' # example data set in the AMR package
-#' esbl_isolates
+#'   # example data set in the AMR package
+#'   esbl_isolates
 #'
-#' # Prepare a binary outcome and convert to ordered factor
-#' data <- esbl_isolates %>%
-#'   mutate(esbl = factor(esbl, levels = c(FALSE, TRUE), ordered = TRUE))
+#'   # Prepare a binary outcome and convert to ordered factor
+#'   data <- esbl_isolates %>%
+#'     mutate(esbl = factor(esbl, levels = c(FALSE, TRUE), ordered = TRUE))
 #'
-#' # Split into training and testing sets
-#' split <- initial_split(data)
-#' training_data <- training(split)
-#' testing_data <- testing(split)
+#'   # Split into training and testing sets
+#'   split <- initial_split(data)
+#'   training_data <- training(split)
+#'   testing_data <- testing(split)
 #'
-#' # Create and prep a recipe with MIC log2 transformation
-#' mic_recipe <- recipe(esbl ~ ., data = training_data) %>%
-#'   # Optionally remove non-predictive variables
-#'   remove_role(genus, old_role = "predictor") %>%
-#'   # Apply the log2 transformation to all MIC predictors
-#'   step_mic_log2(all_mic_predictors()) %>%
-#'   prep()
+#'   # Create and prep a recipe with MIC log2 transformation
+#'   mic_recipe <- recipe(esbl ~ ., data = training_data) %>%
 #'
-#' # View prepped recipe
-#' mic_recipe
+#'     # Optionally remove non-predictive variables
+#'     remove_role(genus, old_role = "predictor") %>%
 #'
-#' # Apply the recipe to training and testing data
-#' out_training <- bake(mic_recipe, new_data = NULL)
-#' out_testing <- bake(mic_recipe, new_data = testing_data)
+#'     # Apply the log2 transformation to all MIC predictors
+#'     step_mic_log2(all_mic_predictors()) %>%
 #'
-#' # Fit a logistic regression model
-#' fitted <- logistic_reg(mode = "classification") %>%
-#'   set_engine("glm") %>%
-#'   fit(esbl ~ ., data = out_training)
+#'     # And apply the preparation steps
+#'     prep()
 #'
-#' # Generate predictions on the test set
-#' predictions <- predict(fitted, out_testing) %>%
-#'   bind_cols(out_testing)
+#'   # View prepped recipe
+#'   mic_recipe
 #'
-#' # Evaluate predictions using standard classification metrics
-#' our_metrics <- metric_set(accuracy, kap, ppv, npv)
-#' metrics <- our_metrics(predictions, truth = esbl, estimate = .pred_class)
+#'   # Apply the recipe to training and testing data
+#'   out_training <- bake(mic_recipe, new_data = NULL)
+#'   out_testing <- bake(mic_recipe, new_data = testing_data)
 #'
-#' # Show performance:
-#' # - negative predictive value (NPV) of ~98%
-#' # - positive predictive value (PPV) of ~94%
-#' metrics
+#'   # Fit a logistic regression model
+#'   fitted <- logistic_reg(mode = "classification") %>%
+#'     set_engine("glm") %>%
+#'     fit(esbl ~ ., data = out_training)
+#'
+#'   # Generate predictions on the test set
+#'   predictions <- predict(fitted, out_testing) %>%
+#'     bind_cols(out_testing)
+#'
+#'   # Evaluate predictions using standard classification metrics
+#'   our_metrics <- metric_set(accuracy, kap, ppv, npv)
+#'   metrics <- our_metrics(predictions, truth = esbl, estimate = .pred_class)
+#'
+#'   # Show performance
+#'   metrics
+#' }
 all_mic <- function() {
   x <- tidymodels_amr_select(levels(NA_mic_))
   names(x)