(v3.0.0.9008) fix ggplot_sir(), support lighter green for SDD

.github/ISSUE_TEMPLATE/1-bug-report.yml

@@ -42,7 +42,7 @@ body:
       multiple: false
       options:
         - ''
-        - Latest CRAN version (2.1.1)
+        - Latest CRAN version (3.0.0)
-        - One of the latest GitHub versions (2.1.1.9xxx)
+        - One of the latest GitHub versions (3.0.0.9xxx)
     validations:
       required: true

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: AMR
-Version: 3.0.0
+Version: 3.0.0.9008
-Date: 2025-06-01
+Date: 2025-07-17
 Title: Antimicrobial Resistance Data Analysis
 Description: Functions to simplify and standardise antimicrobial resistance (AMR)
   data analysis and to work with microbial and antimicrobial properties by
@@ -51,6 +51,8 @@ Suggests:
   pillar,
   progress,
   readxl,
+  recipes,
+  rlang,
   rmarkdown,
   rstudioapi,
   rvest,

NAMESPACE

@@ -106,6 +106,8 @@ S3method(print,mo_uncertainties)
 S3method(print,pca)
 S3method(print,sir)
 S3method(print,sir_log)
+S3method(print,step_mic_log2)
+S3method(print,step_sir_numeric)
 S3method(quantile,mic)
 S3method(rep,ab)
 S3method(rep,av)
@@ -159,6 +161,10 @@ export(administrable_per_os)
 export(age)
 export(age_groups)
 export(all_antimicrobials)
+export(all_mic)
+export(all_mic_predictors)
+export(all_sir)
+export(all_sir_predictors)
 export(aminoglycosides)
 export(aminopenicillins)
 export(amr_class)
@@ -352,6 +358,8 @@ export(sir_df)
 export(sir_interpretation_history)
 export(sir_predict)
 export(skewness)
+export(step_mic_log2)
+export(step_sir_numeric)
 export(streptogramins)
 export(sulfonamides)
 export(susceptibility)
@@ -388,6 +396,12 @@ if(getRversion() >= "3.0.0") S3method(pillar::type_sum, av)
 if(getRversion() >= "3.0.0") S3method(pillar::type_sum, mic)
 if(getRversion() >= "3.0.0") S3method(pillar::type_sum, mo)
 if(getRversion() >= "3.0.0") S3method(pillar::type_sum, sir)
+if(getRversion() >= "3.0.0") S3method(recipes::bake, step_mic_log2)
+if(getRversion() >= "3.0.0") S3method(recipes::bake, step_sir_numeric)
+if(getRversion() >= "3.0.0") S3method(recipes::prep, step_mic_log2)
+if(getRversion() >= "3.0.0") S3method(recipes::prep, step_sir_numeric)
+if(getRversion() >= "3.0.0") S3method(recipes::tidy, step_mic_log2)
+if(getRversion() >= "3.0.0") S3method(recipes::tidy, step_sir_numeric)
 if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, disk)
 if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, mic)
 if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, mo)

NEWS.md

@@ -1,3 +1,24 @@
+# AMR 3.0.0.9008
+
+This is primarily a bugfix release, though we added one nice feature too.
+
+### New
+* Integration with the **tidymodels** framework to allow seamless use of MIC and SIR data in modelling pipelines via `recipes`
+  - `step_mic_log2()` to transform `<mic>` columns with log2, and `step_sir_numeric()` to convert `<sir>` columns to numeric
+  - New `tidyselect` helpers: `all_mic()`, `all_mic_predictors()`, `all_sir()`, `all_sir_predictors()`
+
+### Changed
+* Fixed a bug in `antibiogram()` for when no antimicrobials are set
+* Fixed a bug in `antibiogram()` to allow column names containing the `+` character (#222)
+* Fixed a bug in `as.ab()` for antimicrobial codes with a number in it if they are preceded by a space
+* Fixed a bug in `eucast_rules()` for using specific custom rules
+* Fixed a bug in `as.sir()` to allow any tidyselect language (#220)
+* Fixed a bug in `ggplot_sir()` when using `combine_SI = FALSE` (#213)
+* Fixed all plotting to contain a separate colour for SDD (susceptible dose-dependent)
+* Fixed some specific Dutch translations for antimicrobials
+* Updated `random_mic()` and `random_disk()` to set skewedness of the distribution and allow multiple microorganisms
+
+
 # AMR 3.0.0
 
 This package now supports not only tools for AMR data analysis in clinical settings, but also for veterinary and environmental microbiology. This was made possible through a collaboration with the [University of Prince Edward Island's Atlantic Veterinary College](https://www.upei.ca/avc), Canada. To celebrate this great improvement of the package, we also updated the package logo to reflect this change.
@@ -122,7 +143,7 @@ This package now supports not only tools for AMR data analysis in clinical setti
 
 ## Older Versions
 
-This changelog only contains changes from AMR v3.0 (March 2025) and later.
+This changelog only contains changes from AMR v3.0 (June 2025) and later.
 
 * For prior v2 versions, please see [our v2 archive](https://github.com/msberends/AMR/blob/v2.1.1/NEWS.md).
 * For prior v1 versions, please see [our v1 archive](https://github.com/msberends/AMR/blob/v1.8.2/NEWS.md).

R/aa_helper_functions.R

@@ -63,31 +63,6 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
   merged
 }
 
-# support where() like tidyverse (this function will also be used when running `antibiogram()`):
-where <- function(fn) {
-  # based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
-  if (!is.function(fn)) {
-    stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
-  }
-  df <- pm_select_env$.data
-  cols <- pm_select_env$get_colnames()
-  if (is.null(df)) {
-    df <- get_current_data("where", call = FALSE)
-    cols <- colnames(df)
-  }
-  preds <- unlist(lapply(
-    df,
-    function(x, fn) {
-      do.call("fn", list(x))
-    },
-    fn
-  ))
-  if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
-  data_cols <- cols
-  cols <- data_cols[preds]
-  which(data_cols %in% cols)
-}
-
 # copied and slightly rewritten from {poorman} under permissive license (2021-10-15)
 # https://github.com/nathaneastwood/poorman, MIT licensed, Nathan Eastwood, 2020
 case_when_AMR <- function(...) {
@@ -814,7 +789,7 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
 
   # if object is missing, or another error:
   tryCatch(invisible(object),
-    error = function(e) AMR_env$meet_criteria_error_txt <- e$message
+    error = function(e) AMR_env$meet_criteria_error_txt <- conditionMessage(e)
   )
   if (!is.null(AMR_env$meet_criteria_error_txt)) {
     error_txt <- AMR_env$meet_criteria_error_txt
@@ -1244,7 +1219,9 @@ try_colour <- function(..., before, after, collapse = " ") {
   }
 }
 is_dark <- function() {
-  if (is.null(AMR_env$is_dark_theme)) {
+  AMR_env$current_theme <- tryCatch(getExportedValue("getThemeInfo", ns = asNamespace("rstudioapi"))()$editor, error = function(e) NULL)
+  if (!identical(AMR_env$current_theme, AMR_env$former_theme) || is.null(AMR_env$is_dark_theme)) {
+    AMR_env$former_theme <- AMR_env$current_theme
     AMR_env$is_dark_theme <- !has_colour() || tryCatch(isTRUE(getExportedValue("getThemeInfo", ns = asNamespace("rstudioapi"))()$dark), error = function(e) FALSE)
   }
   isTRUE(AMR_env$is_dark_theme)
@@ -1317,6 +1294,10 @@ font_green_bg <- function(..., collapse = " ") {
   # this is #3caea3 (picked to be colourblind-safe with other SIR colours)
   try_colour(font_black(..., collapse = collapse, adapt = FALSE), before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
 }
+font_green_lighter_bg <- function(..., collapse = " ") {
+  # this is #8FD6C4 (picked to be colourblind-safe with other SIR colours)
+  try_colour(font_black(..., collapse = collapse, adapt = FALSE), before = "\033[48;5;158m", after = "\033[49m", collapse = collapse)
+}
 font_purple_bg <- function(..., collapse = " ") {
   try_colour(font_black(..., collapse = collapse, adapt = FALSE), before = "\033[48;5;89m", after = "\033[49m", collapse = collapse)
 }
@@ -1634,6 +1615,36 @@ get_n_cores <- function(max_cores = Inf) {
   n_cores
 }
 
+# Support `where()` if tidyselect not installed ----
+if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
+  # tidyselect::where() exists, load the namespace to make `where()`s work across the package in default arguments
+  loadNamespace("tidyselect")
+} else {
+  where <- function(fn) {
+    # based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
+    if (!is.function(fn)) {
+      stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
+    }
+    df <- pm_select_env$.data
+    cols <- pm_select_env$get_colnames()
+    if (is.null(df)) {
+      df <- get_current_data("where", call = FALSE)
+      cols <- colnames(df)
+    }
+    preds <- unlist(lapply(
+      df,
+      function(x, fn) {
+        do.call("fn", list(x))
+      },
+      fn
+    ))
+    if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
+    data_cols <- cols
+    cols <- data_cols[preds]
+    which(data_cols %in% cols)
+  }
+}
+
 # Faster data.table implementations ----
 
 match <- function(x, table, ...) {
@@ -1653,52 +1664,6 @@ match <- function(x, table, ...) {
   }
 }
 
-# nolint start
-
-# Register S3 methods ----
-# copied from vctrs::s3_register by their permission:
-# https://github.com/r-lib/vctrs/blob/05968ce8e669f73213e3e894b5f4424af4f46316/R/register-s3.R
-s3_register <- function(generic, class, method = NULL) {
-  stopifnot(is.character(generic), length(generic) == 1)
-  stopifnot(is.character(class), length(class) == 1)
-  pieces <- strsplit(generic, "::")[[1]]
-  stopifnot(length(pieces) == 2)
-  package <- pieces[[1]]
-  generic <- pieces[[2]]
-  caller <- parent.frame()
-  get_method_env <- function() {
-    top <- topenv(caller)
-    if (isNamespace(top)) {
-      asNamespace(environmentName(top))
-    } else {
-      caller
-    }
-  }
-  get_method <- function(method, env) {
-    if (is.null(method)) {
-      get(paste0(generic, ".", class), envir = get_method_env())
-    } else {
-      method
-    }
-  }
-  method_fn <- get_method(method)
-  stopifnot(is.function(method_fn))
-  setHook(packageEvent(package, "onLoad"), function(...) {
-    ns <- asNamespace(package)
-    method_fn <- get_method(method)
-    registerS3method(generic, class, method_fn, envir = ns)
-  })
-  if (!isNamespaceLoaded(package)) {
-    return(invisible())
-  }
-  envir <- asNamespace(package)
-  if (exists(generic, envir)) {
-    registerS3method(generic, class, method_fn, envir = envir)
-  }
-  invisible()
-}
-
-
 # Support old R versions ----
 # these functions were not available in previous versions of R
 # see here for the full list: https://github.com/r-lib/backports

R/aa_helper_pm_functions.R

@@ -952,7 +952,19 @@ pm_select_env$get_nrow <- function() nrow(pm_select_env$.data)
 pm_select_env$get_ncol <- function() ncol(pm_select_env$.data)
 
 pm_select <- function(.data, ...) {
-  col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
+  # col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE),
+  col_pos <- tryCatch(pm_select_positions(.data, ..., .group_pos = TRUE), error = function(e) NULL)
+  if (is.null(col_pos)) {
+    # try with tidyverse
+    select_dplyr <- import_fn("select", "dplyr", error_on_fail = FALSE)
+    if (!is.null(select_dplyr)) {
+      col_pos <- which(colnames(.data) %in% colnames(select_dplyr(.data, ...)))
+    } else {
+      # this will throw an error as it did, but dplyr is not available, so no other option
+      col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
+    }
+  }
+
   map_names <- names(col_pos)
   map_names_length <- nchar(map_names)
   if (any(map_names_length == 0L)) {

R/ab.R

@@ -184,7 +184,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
   x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
   previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
   x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
-  if (any(previously_coerced) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) {
+  previously_coerced_mention <- x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name
+  if (any(previously_coerced_mention) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) {
     message_(
       "Returning previously coerced ",
       ifelse(length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) > 1, "value for an antimicrobial", "values for various antimicrobials"),
@@ -655,7 +656,9 @@ generalise_antibiotic_name <- function(x) {
   x <- trimws(gsub(" +", " ", x, perl = TRUE))
   # remove last couple of words if they numbers or units
   x <- gsub("( ([0-9]{3,}|U?M?C?G|L))+$", "", x, perl = TRUE)
-  # move HIGH to end
+  # remove whitespace prior to numbers if preceded by A-Z
+  x <- gsub("([A-Z]+) +([0-9]+)", "\\1\\2", x, perl = TRUE)
+  # move HIGH to the end
   x <- trimws(gsub("(.*) HIGH(.*)", "\\1\\2 HIGH", x, perl = TRUE))
   x
 }

R/ab_property.R

@@ -445,7 +445,7 @@ ab_validate <- function(x, property, ...) {
     # try to catch an error when inputting an invalid argument
     # so the 'call.' can be set to FALSE
     tryCatch(x[1L] %in% AMR_env$AB_lookup[1, property, drop = TRUE],
-      error = function(e) stop(e$message, call. = FALSE)
+      error = function(e) stop(conditionMessage(e), call. = FALSE)
     )
 
     if (!all(x %in% AMR_env$AB_lookup[, property, drop = TRUE])) {

R/age.R

@@ -208,7 +208,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
     split_at <- c(0, split_at)
   }
   split_at <- split_at[!is.na(split_at)]
-  stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
+  stop_if(length(split_at) == 1, "invalid value for `split_at`.") # only 0 is available
 
   # turn input values to 'split_at' indices
   y <- x

R/amr_selectors.R

@@ -527,7 +527,7 @@ amr_selector <- function(filter,
   )
   call <- substitute(filter)
   agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
-    error = function(e) stop_(e$message, call = -5)
+    error = function(e) stop_(conditionMessage(e), call = -5)
   )
   agents <- ab_in_data[ab_in_data %in% agents]
   message_agent_names(
@@ -640,7 +640,7 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
         )
       }
     ),
-    error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
+    error = function(e) stop_("in not_intrinsic_resistant(): ", conditionMessage(e), call = FALSE)
   )
 
   agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]

R/antibiogram.R

@@ -40,6 +40,7 @@
 #'   - A combination of the above, using `c()`, e.g.:
 #'     - `c(aminoglycosides(), "AMP", "AMC")`
 #'     - `c(aminoglycosides(), carbapenems())`
+#'   - Column indices using numbers
 #'   - Combination therapy, indicated by using `"+"`, with or without [antimicrobial selectors][antimicrobial_selectors], e.g.:
 #'     - `"cipro + genta"`
 #'     - `"TZP+TOB"`
@@ -452,7 +453,7 @@ antibiogram.default <- function(x,
     deprecation_warning("antibiotics", "antimicrobials", fn = "antibiogram", is_argument = TRUE)
     antimicrobials <- list(...)$antibiotics
   }
-  meet_criteria(antimicrobials, allow_class = "character", allow_NA = FALSE, allow_NULL = FALSE)
+  meet_criteria(antimicrobials, allow_class = c("character", "numeric", "integer"), allow_NA = FALSE, allow_NULL = FALSE)
   if (!is.function(mo_transform)) {
     meet_criteria(mo_transform, allow_class = "character", has_length = 1, is_in = c("name", "shortname", "gramstain", colnames(AMR::microorganisms)), allow_NULL = TRUE, allow_NA = TRUE)
   }
@@ -575,6 +576,15 @@ antibiogram.default <- function(x,
     }
     antimicrobials <- unlist(antimicrobials)
   } else {
+    existing_ab_combined_cols <- ab_trycatch[ab_trycatch %like% "[+]" & ab_trycatch %in% colnames(x)]
+    if (length(existing_ab_combined_cols) > 0 && !is.null(ab_transform)) {
+      ab_transform <- NULL
+      warning_(
+        "Detected column name(s) containing the '+' character, which conflicts with the expected syntax in `antibiogram()`: the '+' is used to combine separate antimicrobial agent columns (e.g., \"AMP+GEN\").\n\n",
+        "To avoid incorrectly guessing which antimicrobials this represents, `ab_transform` was automatically set to `NULL`.\n\n",
+        "If this is unintended, please rename the column(s) to avoid using '+' in the name, or set `ab_transform = NULL` explicitly to suppress this message."
+      )
+    }
     antimicrobials <- ab_trycatch
   }
 
@@ -1194,12 +1204,13 @@ retrieve_wisca_parameters <- function(wisca_model, ...) {
 #' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::tbl_sum, antibiogram)
 tbl_sum.antibiogram <- function(x, ...) {
   dims <- paste(format(NROW(x), big.mark = ","), AMR_env$cross_icon, format(NCOL(x), big.mark = ","))
+  names(dims) <- "An Antibiogram"
   if (isTRUE(attributes(x)$wisca)) {
-    names(dims) <- paste0("An Antibiogram (WISCA / ", attributes(x)$conf_interval * 100, "% CI)")
+    dims <- c(dims, Type = paste0("WISCA with ", attributes(x)$conf_interval * 100, "% CI"))
   } else if (isTRUE(attributes(x)$formatting_type >= 13)) {
-    names(dims) <- paste0("An Antibiogram (non-WISCA / ", attributes(x)$conf_interval * 100, "% CI)")
+    dims <- c(dims, Type = paste0("Non-WISCA with ", attributes(x)$conf_interval * 100, "% CI"))
   } else {
-    names(dims) <- paste0("An Antibiogram (non-WISCA)")
+    dims <- c(dims, Type = paste0("Non-WISCA without CI"))
   }
   dims
 }

R/av_property.R

@@ -264,7 +264,7 @@ av_validate <- function(x, property, ...) {
     # try to catch an error when inputting an invalid argument
     # so the 'call.' can be set to FALSE
     tryCatch(x[1L] %in% AMR_env$AV_lookup[1, property, drop = TRUE],
-      error = function(e) stop(e$message, call. = FALSE)
+      error = function(e) stop(conditionMessage(e), call. = FALSE)
     )
 
     if (!all(x %in% AMR_env$AV_lookup[, property, drop = TRUE])) {

R/count.R

@@ -126,7 +126,7 @@ count_resistant <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -139,7 +139,7 @@ count_susceptible <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -152,7 +152,7 @@ count_S <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -165,7 +165,7 @@ count_SI <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -178,7 +178,7 @@ count_I <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -191,7 +191,7 @@ count_IR <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -204,7 +204,7 @@ count_R <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -217,7 +217,7 @@ count_all <- function(..., only_all_tested = FALSE) {
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -240,6 +240,6 @@ count_df <- function(data,
       combine_SI = combine_SI,
       confidence_level = 0.95 # doesn't matter, will be removed
     ),
-    error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc_df(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }

R/custom_mdro_guideline.R

@@ -175,7 +175,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
 
     # Value
     val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL)
-    stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message))
+    stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) conditionMessage(e)))
     stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val))
     out[[i]]$value <- as.character(val)
   }
@@ -254,7 +254,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
   for (i in seq_len(n_dots)) {
     qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()),
       error = function(e) {
-        AMR_env$err_msg <- e$message
+        AMR_env$err_msg <- conditionMessage(e)
         return("error")
       }
     )

R/data.R

@@ -361,3 +361,15 @@
 #' @examples
 #' dosage
 "dosage"
+
+#' Data Set with `r format(nrow(esbl_isolates), big.mark = " ")` ESBL Isolates
+#'
+#' A data set containing `r format(nrow(esbl_isolates), big.mark = " ")` microbial isolates with MIC values of common antibiotics and a binary `esbl` column for extended-spectrum beta-lactamase (ESBL) production. This data set contains randomised fictitious data but reflects reality and can be used to practise AMR-related machine learning, e.g., classification modelling with [tidymodels](https://amr-for-r.org/articles/AMR_with_tidymodels.html).
+#' @format A [tibble][tibble::tibble] with `r format(nrow(esbl_isolates), big.mark = " ")` observations and `r ncol(esbl_isolates)` variables:
+#' - `esbl`\cr Logical indicator if the isolate is ESBL-producing
+#' - `genus`\cr Genus of the microorganism
+#' - `AMC:COL`\cr MIC values for 17 antimicrobial agents, transformed to class [`mic`] (see [as.mic()])
+#' @details See our [tidymodels integration][amr-tidymodels] for an example using this data set.
+#' @examples
+#' esbl_isolates
+"esbl_isolates"

R/eucast_rules.R

@@ -442,7 +442,7 @@ eucast_rules <- function(x,
     # big speed gain! only analyse unique rows:
     pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
     as.data.frame(stringsAsFactors = FALSE)
-  x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = info)
+  x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = FALSE)
   # rename col_mo to prevent interference with joined columns
   colnames(x)[colnames(x) == col_mo] <- ".col_mo"
   col_mo <- ".col_mo"
@@ -450,13 +450,20 @@ eucast_rules <- function(x,
   x <- left_join_microorganisms(x, by = col_mo, suffix = c("_oldcols", ""))
   x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE)
   x$genus_species <- trimws(paste(x$genus, x$species))
-  if (isTRUE(info) && NROW(x) > 10000) {
+  if (isTRUE(info) && NROW(x.bak) > 10000) {
-    message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
+    message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
   }
 
   n_added <- 0
   n_changed <- 0
 
+  rule_current <- ""
+  rule_group_current <- ""
+  rule_group_previous <- ""
+  rule_next <- ""
+  rule_previous <- ""
+  rule_text <- ""
+
   # >>> Apply Other rules: enzyme inhibitors <<< ------------------------------------------
   if (any(c("all", "other") %in% rules)) {
     if (isTRUE(info)) {
@@ -617,31 +624,16 @@ eucast_rules <- function(x,
     eucast_rules_df <- eucast_rules_df %pm>%
       rbind_AMR(eucast_rules_df_total %pm>%
         subset(reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints))
-    # eucast_rules_df <- subset(
-    #   eucast_rules_df,
-    #   reference.rule_group %unlike% "breakpoint" |
-    #     (reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints)
-    # )
   }
   if (any(c("all", "expected_phenotypes") %in% rules)) {
     eucast_rules_df <- eucast_rules_df %pm>%
       rbind_AMR(eucast_rules_df_total %pm>%
         subset(reference.rule_group %like% "expected" & reference.version == version_expected_phenotypes))
-    # eucast_rules_df <- subset(
-    #   eucast_rules_df,
-    #   reference.rule_group %unlike% "expected" |
-    #     (reference.rule_group %like% "expected" & reference.version == version_expected_phenotypes)
-    # )
   }
   if (any(c("all", "expert") %in% rules)) {
     eucast_rules_df <- eucast_rules_df %pm>%
       rbind_AMR(eucast_rules_df_total %pm>%
         subset(reference.rule_group %like% "expert" & reference.version == version_expertrules))
-    # eucast_rules_df <- subset(
-    #   eucast_rules_df,
-    #   reference.rule_group %unlike% "expert" |
-    #     (reference.rule_group %like% "expert" & reference.version == version_expertrules)
-    # )
   }
   ## filter out AmpC de-repressed cephalosporin-resistant mutants ----
   # no need to filter on version number here - the rules contain these version number, so are inherently filtered
@@ -664,6 +656,9 @@ eucast_rules <- function(x,
   # we only hints on remaining rows in `eucast_rules_df`
   screening_abx <- as.character(AMR::antimicrobials$ab[which(AMR::antimicrobials$ab %like% "-S$")])
   screening_abx <- screening_abx[screening_abx %in% unique(unlist(strsplit(EUCAST_RULES_DF$and_these_antibiotics[!is.na(EUCAST_RULES_DF$and_these_antibiotics)], ", *")))]
+  if (isTRUE(info)) {
+    cat("\n")
+  }
   for (ab_s in screening_abx) {
     ab <- gsub("-S$", "", ab_s)
     if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
@@ -894,7 +889,9 @@ eucast_rules <- function(x,
     }
     for (i in seq_len(length(custom_rules))) {
       rule <- custom_rules[[i]]
-      rows <- which(eval(parse(text = rule$query), envir = x))
+      rows <- tryCatch(which(eval(parse(text = rule$query), envir = x)),
+        error = function(e) stop_(paste0(conditionMessage(e), font_red(" (check available data and compare with the custom rules set)")), call = FALSE)
+      )
       cols <- as.character(rule$result_group)
       cols <- c(
         cols[cols %in% colnames(x)], # direct column names
@@ -908,9 +905,8 @@ eucast_rules <- function(x,
         get_antibiotic_names(cols)
       )
       if (isTRUE(info)) {
-        # print rule
         cat(italicise_taxonomy(
-          word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
+          word_wrap(rule_text,
             width = getOption("width") - 30,
             extra_indent = 6
           ),
@@ -1182,7 +1178,7 @@ edit_sir <- function(x,
             ifelse(length(rows) > 10, "...", ""),
             " while writing value '", to,
             "' to column(s) `", paste(cols, collapse = "`, `"),
-            "`:\n", e$message
+            "`:\n", conditionMessage(e)
           ),
           call. = FALSE
         )

R/ggplot_sir.R

@@ -178,6 +178,7 @@ ggplot_sir <- function(data,
                        colours = c(
                          S = "#3CAEA3",
                          SI = "#3CAEA3",
+                         SDD = "#8FD6C4",
                          I = "#F6D55C",
                          IR = "#ED553B",
                          R = "#ED553B"

R/mean_amr_distance.R

@@ -31,7 +31,7 @@
 #'
 #' Calculates a normalised mean for antimicrobial resistance between multiple observations, to help to identify similar isolates without comparing antibiograms by hand.
 #' @param x A vector of class [sir][as.sir()], [mic][as.mic()] or [disk][as.disk()], or a [data.frame] containing columns of any of these classes.
-#' @param ... Variables to select. Supports [tidyselect language][tidyselect::language] (such as `column1:column4` and `where(is.mic)`), and can thus also be [antimicrobial selectors][amr_selector()].
+#' @param ... Variables to select. Supports [tidyselect language][tidyselect::starts_with()] such as `where(is.mic)`, `starts_with(...)`, or `column1:column4`, and can thus also be [antimicrobial selectors][amr_selector()].
 #' @param combine_SI A [logical] to indicate whether all values of S, SDD, and I must be merged into one, so the input only consists of S+I vs. R (susceptible vs. resistant) - the default is `TRUE`.
 #' @details The mean AMR distance is effectively [the Z-score](https://en.wikipedia.org/wiki/Standard_score); a normalised numeric value to compare AMR test results which can help to identify similar isolates, without comparing antibiograms by hand.
 #'

R/mic.R

@@ -432,11 +432,17 @@ pillar_shaft.mic <- function(x, ...) {
   }
   crude_numbers <- as.double(x)
   operators <- gsub("[^<=>]+", "", as.character(x))
+  # colourise operators
   operators[!is.na(operators) & operators != ""] <- font_silver(operators[!is.na(operators) & operators != ""], collapse = NULL)
   out <- trimws(paste0(operators, trimws(format(crude_numbers))))
   out[is.na(x)] <- font_na(NA)
   # make trailing zeroes less visible
-  out[out %like% "[.]"] <- gsub("([.]?0+)$", font_silver("\\1"), out[out %like% "[.]"], perl = TRUE)
+  if (is_dark()) {
+    fn <- font_silver
+  } else {
+    fn <- font_white
+  }
+  out[out %like% "[.]"] <- gsub("([.]?0+)$", fn("\\1"), out[out %like% "[.]"], perl = TRUE)
   create_pillar_column(out, align = "right", width = max(nchar(font_stripstyle(out))))
 }
 

R/mo.R

@@ -1186,7 +1186,7 @@ parse_and_convert <- function(x) {
         parsed <- gsub('"', "", parsed, fixed = TRUE)
         parsed
       },
-      error = function(e) stop(e$message, call. = FALSE)
+      error = function(e) stop(conditionMessage(e), call. = FALSE)
     ) # this will also be thrown when running `as.mo(no_existing_object)`
   }
   out <- trimws2(out)

R/mo_property.R

@@ -974,7 +974,7 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
   # try to catch an error when inputting an invalid argument
   # so the 'call.' can be set to FALSE
   tryCatch(x[1L] %in% unlist(AMR_env$MO_lookup[1, property, drop = TRUE]),
-    error = function(e) stop(e$message, call. = FALSE)
+    error = function(e) stop(conditionMessage(e), call. = FALSE)
   )
 
   dots <- list(...)

R/pca.R

@@ -99,7 +99,7 @@ pca <- function(x,
     new_list <- list(0)
     for (i in seq_len(length(dots) - 1)) {
       new_list[[i]] <- tryCatch(eval(dots[[i + 1]], envir = x),
-        error = function(e) stop(e$message, call. = FALSE)
+        error = function(e) stop(conditionMessage(e), call. = FALSE)
       )
       if (length(new_list[[i]]) == 1) {
         if (is.character(new_list[[i]]) && new_list[[i]] %in% colnames(x)) {

R/plotting.R

@@ -377,6 +377,13 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
   args <- list(...)
   args[c("value", "labels", "limits")] <- NULL
 
+  if (length(colours_SIR) == 1) {
+    colours_SIR <- rep(colours_SIR, 4)
+  } else if (length(colours_SIR) == 3) {
+    colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
+  }
+  colours_SIR <- unname(colours_SIR)
+
   if (identical(aesthetics, "x")) {
     ggplot_fn <- ggplot2::scale_x_discrete
   } else {
@@ -388,8 +395,8 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
         values = c(
           S = colours_SIR[1],
           SDD = colours_SIR[2],
-          I = colours_SIR[2],
+          I = colours_SIR[3],
-          R = colours_SIR[3],
+          R = colours_SIR[4],
           NI = "grey30"
         )
       )
@@ -427,11 +434,16 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
 
 #' @rdname plot
 #' @export
-scale_x_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_x_sir <- function(colours_SIR = c(
+                          S = "#3CAEA3",
+                          SDD = "#8FD6C4",
+                          I = "#F6D55C",
+                          R = "#ED553B"
+                        ),
                         language = get_AMR_locale(),
                         eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
                         ...) {
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
   create_scale_sir(aesthetics = "x", colours_SIR = colours_SIR, language = language, eucast_I = eucast_I)
@@ -439,11 +451,16 @@ scale_x_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
 
 #' @rdname plot
 #' @export
-scale_colour_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_colour_sir <- function(colours_SIR = c(
+                               S = "#3CAEA3",
+                               SDD = "#8FD6C4",
+                               I = "#F6D55C",
+                               R = "#ED553B"
+                             ),
                              language = get_AMR_locale(),
                              eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
                              ...) {
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
   args <- list(...)
@@ -463,11 +480,16 @@ scale_color_sir <- scale_colour_sir
 
 #' @rdname plot
 #' @export
-scale_fill_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_fill_sir <- function(colours_SIR = c(
+                             S = "#3CAEA3",
+                             SDD = "#8FD6C4",
+                             I = "#F6D55C",
+                             R = "#ED553B"
+                           ),
                            language = get_AMR_locale(),
                            eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
                            ...) {
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
   args <- list(...)
@@ -491,7 +513,12 @@ plot.mic <- function(x,
                      main = deparse(substitute(x)),
                      ylab = translate_AMR("Frequency", language = language),
                      xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
-                     colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                     colours_SIR = c(
+                       S = "#3CAEA3",
+                       SDD = "#8FD6C4",
+                       I = "#F6D55C",
+                       R = "#ED553B"
+                     ),
                      language = get_AMR_locale(),
                      expand = TRUE,
                      include_PKPD = getOption("AMR_include_PKPD", TRUE),
@@ -503,15 +530,11 @@ plot.mic <- function(x,
   meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
   meet_criteria(ylab, allow_class = "character", has_length = 1)
   meet_criteria(xlab, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
   x <- as.mic(x) # make sure that currently implemented MIC levels are used
-
-  if (length(colours_SIR) == 1) {
-    colours_SIR <- rep(colours_SIR, 3)
-  }
   main <- gsub(" +", " ", paste0(main, collapse = " "))
 
   x <- plotrange_as_table(x, expand = expand)
@@ -549,13 +572,17 @@ plot.mic <- function(x,
       legend_col <- colours_SIR[1]
     }
     if (any(cols_sub$cols == colours_SIR[2] & cols_sub$count > 0)) {
-      legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
+      legend_txt <- c(legend_txt, "(SDD) Susceptible dose-dependent")
       legend_col <- c(legend_col, colours_SIR[2])
     }
     if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
-      legend_txt <- c(legend_txt, "(R) Resistant")
+      legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
       legend_col <- c(legend_col, colours_SIR[3])
     }
+    if (any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
+      legend_txt <- c(legend_txt, "(R) Resistant")
+      legend_col <- c(legend_col, colours_SIR[4])
+    }
 
     legend("top",
       x.intersp = 0.5,
@@ -580,7 +607,12 @@ barplot.mic <- function(height,
                         main = deparse(substitute(height)),
                         ylab = translate_AMR("Frequency", language = language),
                         xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
-                        colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                        colours_SIR = c(
+                          S = "#3CAEA3",
+                          SDD = "#8FD6C4",
+                          I = "#F6D55C",
+                          R = "#ED553B"
+                        ),
                         language = get_AMR_locale(),
                         expand = TRUE,
                         ...) {
@@ -590,7 +622,7 @@ barplot.mic <- function(height,
   meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
   meet_criteria(guideline, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
@@ -622,7 +654,12 @@ autoplot.mic <- function(object,
                          title = deparse(substitute(object)),
                          ylab = translate_AMR("Frequency", language = language),
                          xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
-                         colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                         colours_SIR = c(
+                           S = "#3CAEA3",
+                           SDD = "#8FD6C4",
+                           I = "#F6D55C",
+                           R = "#ED553B"
+                         ),
                          language = get_AMR_locale(),
                          expand = TRUE,
                          include_PKPD = getOption("AMR_include_PKPD", TRUE),
@@ -635,7 +672,7 @@ autoplot.mic <- function(object,
   meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
   meet_criteria(ylab, allow_class = "character", has_length = 1)
   meet_criteria(xlab, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
@@ -731,7 +768,12 @@ plot.disk <- function(x,
                       mo = NULL,
                       ab = NULL,
                       guideline = getOption("AMR_guideline", "EUCAST"),
-                      colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                      colours_SIR = c(
+                        S = "#3CAEA3",
+                        SDD = "#8FD6C4",
+                        I = "#F6D55C",
+                        R = "#ED553B"
+                      ),
                       language = get_AMR_locale(),
                       expand = TRUE,
                       include_PKPD = getOption("AMR_include_PKPD", TRUE),
@@ -743,13 +785,10 @@ plot.disk <- function(x,
   meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
   meet_criteria(guideline, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
-  if (length(colours_SIR) == 1) {
-    colours_SIR <- rep(colours_SIR, 3)
-  }
   main <- gsub(" +", " ", paste0(main, collapse = " "))
 
   x <- plotrange_as_table(x, expand = expand)
@@ -783,12 +822,16 @@ plot.disk <- function(x,
   if (any(colours_SIR %in% cols_sub$cols)) {
     legend_txt <- character(0)
     legend_col <- character(0)
-    if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
+    if (any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
       legend_txt <- "(R) Resistant"
-      legend_col <- colours_SIR[3]
+      legend_col <- colours_SIR[4]
+    }
+    if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
+      legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
+      legend_col <- c(legend_col, colours_SIR[3])
     }
     if (any(cols_sub$cols == colours_SIR[2] & cols_sub$count > 0)) {
-      legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
+      legend_txt <- c(legend_txt, "(SDD) Susceptible dose-dependent")
       legend_col <- c(legend_col, colours_SIR[2])
     }
     if (any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
@@ -818,7 +861,12 @@ barplot.disk <- function(height,
                          mo = NULL,
                          ab = NULL,
                          guideline = getOption("AMR_guideline", "EUCAST"),
-                         colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                         colours_SIR = c(
+                           S = "#3CAEA3",
+                           SDD = "#8FD6C4",
+                           I = "#F6D55C",
+                           R = "#ED553B"
+                         ),
                          language = get_AMR_locale(),
                          expand = TRUE,
                          ...) {
@@ -828,7 +876,7 @@ barplot.disk <- function(height,
   meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
   meet_criteria(guideline, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
@@ -858,7 +906,12 @@ autoplot.disk <- function(object,
                           ylab = translate_AMR("Frequency", language = language),
                           xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
                           guideline = getOption("AMR_guideline", "EUCAST"),
-                          colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                          colours_SIR = c(
+                            S = "#3CAEA3",
+                            SDD = "#8FD6C4",
+                            I = "#F6D55C",
+                            R = "#ED553B"
+                          ),
                           language = get_AMR_locale(),
                           expand = TRUE,
                           include_PKPD = getOption("AMR_include_PKPD", TRUE),
@@ -871,7 +924,7 @@ autoplot.disk <- function(object,
   meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
   meet_criteria(guideline, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
@@ -1024,22 +1077,31 @@ barplot.sir <- function(height,
                         main = deparse(substitute(height)),
                         xlab = translate_AMR("Antimicrobial Interpretation", language = language),
                         ylab = translate_AMR("Frequency", language = language),
-                        colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                        colours_SIR = c(
+                          S = "#3CAEA3",
+                          SDD = "#8FD6C4",
+                          I = "#F6D55C",
+                          R = "#ED553B"
+                        ),
                         language = get_AMR_locale(),
                         expand = TRUE,
                         ...) {
   meet_criteria(xlab, allow_class = "character", has_length = 1)
   meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
   meet_criteria(ylab, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
   if (length(colours_SIR) == 1) {
-    colours_SIR <- rep(colours_SIR, 3)
+    colours_SIR <- rep(colours_SIR, 4)
+  } else if (length(colours_SIR) == 3) {
+    colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
   }
+  colours_SIR <- unname(colours_SIR)
+
   # add SDD and N to colours
-  colours_SIR <- c(colours_SIR[1:2], colours_SIR[2], colours_SIR[3], "#888888")
+  colours_SIR <- c(colours_SIR, "grey30")
   main <- gsub(" +", " ", paste0(main, collapse = " "))
 
   x <- table(height)
@@ -1065,14 +1127,19 @@ autoplot.sir <- function(object,
                          title = deparse(substitute(object)),
                          xlab = translate_AMR("Antimicrobial Interpretation", language = language),
                          ylab = translate_AMR("Frequency", language = language),
-                         colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+                         colours_SIR = c(
+                           S = "#3CAEA3",
+                           SDD = "#8FD6C4",
+                           I = "#F6D55C",
+                           R = "#ED553B"
+                         ),
                          language = get_AMR_locale(),
                          ...) {
   stop_ifnot_installed("ggplot2")
   meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
   meet_criteria(ylab, allow_class = "character", has_length = 1)
   meet_criteria(xlab, allow_class = "character", has_length = 1)
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
 
   if ("main" %in% names(list(...))) {
     title <- list(...)$main
@@ -1082,8 +1149,11 @@ autoplot.sir <- function(object,
   }
 
   if (length(colours_SIR) == 1) {
-    colours_SIR <- rep(colours_SIR, 3)
+    colours_SIR <- rep(colours_SIR, 4)
+  } else if (length(colours_SIR) == 3) {
+    colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
   }
+  colours_SIR <- unname(colours_SIR)
 
   df <- as.data.frame(table(object), stringsAsFactors = TRUE)
   colnames(df) <- c("x", "n")
@@ -1095,9 +1165,9 @@ autoplot.sir <- function(object,
       values = c(
         "S" = colours_SIR[1],
         "SDD" = colours_SIR[2],
-        "I" = colours_SIR[2],
+        "I" = colours_SIR[3],
-        "R" = colours_SIR[3],
+        "R" = colours_SIR[4],
-        "NI" = "#888888"
+        "NI" = "grey30"
       ),
       limits = force
     ) +
@@ -1182,6 +1252,13 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
 
   guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
 
+  if (length(colours_SIR) == 1) {
+    colours_SIR <- rep(colours_SIR, 4)
+  } else if (length(colours_SIR) == 3) {
+    colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
+  }
+  colours_SIR <- unname(colours_SIR)
+
   # store previous interpretations to backup
   sir_history <- AMR_env$sir_interpretation_history
   # and clear previous interpretations
@@ -1223,9 +1300,9 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
     cols[is.na(sir)] <- "#BEBEBE"
     cols[sir == "S"] <- colours_SIR[1]
     cols[sir == "SDD"] <- colours_SIR[2]
-    cols[sir == "I"] <- colours_SIR[2]
+    cols[sir == "I"] <- colours_SIR[3]
-    cols[sir == "R"] <- colours_SIR[3]
+    cols[sir == "R"] <- colours_SIR[4]
-    cols[sir == "NI"] <- "#888888"
+    cols[sir == "NI"] <- "grey30"
     sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
   } else {
     cols <- "#BEBEBE"
@@ -1284,10 +1361,15 @@ scale_y_percent <- function(breaks = function(x) seq(0, max(x, na.rm = TRUE), 0.
 #' @export
 scale_sir_colours <- function(...,
                               aesthetics,
-                              colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B")) {
+                              colours_SIR = c(
+                                S = "#3CAEA3",
+                                SDD = "#8FD6C4",
+                                I = "#F6D55C",
+                                R = "#ED553B"
+                              )) {
   stop_ifnot_installed("ggplot2")
   meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
-  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
+  meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
 
   if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
     warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.")
@@ -1296,67 +1378,52 @@ scale_sir_colours <- function(...,
     warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.")
   }
 
-  if (length(colours_SIR) == 1) {
-    colours_SIR <- rep(colours_SIR, 3)
-  }
-  # behaviour until AMR pkg v1.5.0 and also when coming from ggplot_sir()
   if ("colours" %in% names(list(...))) {
-    original_cols <- c(
+    colours_SIR <- list(...)$colours
-      S = colours_SIR[1],
+  }
-      SI = colours_SIR[1],
+
-      I = colours_SIR[2],
+  if (length(colours_SIR) == 1) {
-      IR = colours_SIR[3],
+    colours_SIR <- rep(colours_SIR, 4)
-      R = colours_SIR[3]
+  } else if (length(colours_SIR) == 3) {
-    )
+    colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
-    colours <- replace(original_cols, names(list(...)$colours), list(...)$colours)
+  }
+
+  # behaviour when coming from ggplot_sir()
+  if ("colours" %in% names(list(...))) {
     # limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
     # https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530
-    return(ggplot2::scale_fill_manual(values = colours, limits = force, aesthetics = aesthetics))
+    return(ggplot2::scale_fill_manual(values = colours_SIR, limits = force, aesthetics = aesthetics))
   }
   if (identical(unlist(list(...)), FALSE)) {
     return(invisible())
   }
 
-  names_susceptible <- c(
+  colours_SIR <- unname(colours_SIR)
-    "S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
+
-    unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
+  names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible")
-      "replacement",
+  names_susceptible_dose_dep <- c("SDD", "susceptible dose-dependent", "Susceptible dose-dependent")
-      drop = TRUE
-    ])
-  )
   names_incr_exposure <- c(
     "I", "intermediate", "increased exposure", "incr. exposure",
-    "Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
+    "Increased exposure", "Incr. exposure", "Susceptible, incr. exp."
-    unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
-      "replacement",
-      drop = TRUE
-    ]),
-    unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
-      "replacement",
-      drop = TRUE
-    ])
-  )
-  names_resistant <- c(
-    "R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
-    unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
-      "replacement",
-      drop = TRUE
-    ])
   )
+  names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant")
 
   susceptible <- rep(colours_SIR[1], length(names_susceptible))
   names(susceptible) <- names_susceptible
-  incr_exposure <- rep(colours_SIR[2], length(names_incr_exposure))
+  susceptible_dose_dep <- rep(colours_SIR[2], length(names_susceptible_dose_dep))
+  names(susceptible_dose_dep) <- names_susceptible_dose_dep
+  incr_exposure <- rep(colours_SIR[3], length(names_incr_exposure))
   names(incr_exposure) <- names_incr_exposure
-  resistant <- rep(colours_SIR[3], length(names_resistant))
+  resistant <- rep(colours_SIR[4], length(names_resistant))
   names(resistant) <- names_resistant
 
-  original_cols <- c(susceptible, incr_exposure, resistant)
+  original_cols <- c(susceptible, susceptible_dose_dep, incr_exposure, resistant)
   dots <- c(...)
-  # replace S, I, R as colours: scale_sir_colours(mydatavalue = "S")
+  # replace S, SDD, I, R as colours: scale_sir_colours(mydatavalue = "S")
   dots[dots == "S"] <- colours_SIR[1]
-  dots[dots == "I"] <- colours_SIR[2]
+  dots[dots == "SDD"] <- colours_SIR[2]
-  dots[dots == "R"] <- colours_SIR[3]
+  dots[dots == "I"] <- colours_SIR[3]
+  dots[dots == "R"] <- colours_SIR[4]
   cols <- replace(original_cols, names(dots), dots)
   # limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
   # https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530

R/proportion.R

@@ -237,7 +237,7 @@ resistance <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -255,7 +255,7 @@ susceptibility <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -283,7 +283,7 @@ sir_confidence_interval <- function(...,
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
   n <- tryCatch(
     sir_calc(...,
@@ -291,7 +291,7 @@ sir_confidence_interval <- function(...,
       only_all_tested = only_all_tested,
       only_count = TRUE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 
   if (x == 0) {
@@ -347,7 +347,7 @@ proportion_R <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -365,7 +365,7 @@ proportion_IR <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -383,7 +383,7 @@ proportion_I <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -401,7 +401,7 @@ proportion_SI <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -419,7 +419,7 @@ proportion_S <- function(...,
       only_all_tested = only_all_tested,
       only_count = FALSE
     ),
-    error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }
 
@@ -443,6 +443,6 @@ proportion_df <- function(data,
       combine_SI = combine_SI,
       confidence_level = confidence_level
     ),
-    error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc_df(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }

R/random.R

@@ -31,13 +31,17 @@
 #'
 #' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial drug, the generated results will reflect reality as much as possible.
 #' @param size Desired size of the returned vector. If used in a [data.frame] call or `dplyr` verb, will get the current (group) size if left blank.
-#' @param mo Any [character] that can be coerced to a valid microorganism code with [as.mo()].
+#' @param mo Any [character] that can be coerced to a valid microorganism code with [as.mo()]. Can be the same length as `size`.
 #' @param ab Any [character] that can be coerced to a valid antimicrobial drug code with [as.ab()].
 #' @param prob_SIR A vector of length 3: the probabilities for "S" (1st value), "I" (2nd value) and "R" (3rd value).
+#' @param skew Direction of skew for MIC or disk values, either `"right"` or `"left"`. A left-skewed distribution has the majority of the data on the right.
+#' @param severity Skew severity; higher values will increase the skewedness. Default is `2`; use `0` to prevent skewedness.
 #' @param ... Ignored, only in place to allow future extensions.
-#' @details The base \R function [sample()] is used for generating values.
+#' @details
-#'
+#' Internally, MIC and disk zone values are sampled based on clinical breakpoints defined in the [clinical_breakpoints] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument. The MICs are sampled on a log2 scale and disks linearly, using weighted probabilities. The weights are based on the `skew` and `severity` arguments:
-#' Generated values are based on the EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))` guideline as implemented in the [clinical_breakpoints] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument.
+#' * `skew = "right"` places more emphasis on lower MIC or higher disk values.
+#' * `skew = "left"` places more emphasis on higher MIC or lower disk values.
+#' * `severity` controls the exponential bias applied.
 #' @return class `mic` for [random_mic()] (see [as.mic()]) and class `disk` for [random_disk()] (see [as.disk()])
 #' @name random
 #' @rdname random
@@ -47,8 +51,13 @@
 #' random_disk(25)
 #' random_sir(25)
 #'
+#' # add more skewedness, make more realistic by setting a bug and/or drug:
+#' disks <- random_disk(100, severity = 2, mo = "Escherichia coli", ab = "CIP")
+#' plot(disks)
+#' # `plot()` and `ggplot2::autoplot()` allow for coloured bars if `mo` and `ab` are set
+#' plot(disks, mo = "Escherichia coli", ab = "CIP", guideline = "CLSI 2025")
+#'
 #' \donttest{
-#' # make the random generation more realistic by setting a bug and/or drug:
 #' random_mic(25, "Klebsiella pneumoniae") # range 0.0625-64
 #' random_mic(25, "Klebsiella pneumoniae", "meropenem") # range 0.0625-16
 #' random_mic(25, "Streptococcus pneumoniae", "meropenem") # range 0.0625-4
@@ -57,26 +66,61 @@
 #' random_disk(25, "Klebsiella pneumoniae", "ampicillin") # range 11-17
 #' random_disk(25, "Streptococcus pneumoniae", "ampicillin") # range 12-27
 #' }
-random_mic <- function(size = NULL, mo = NULL, ab = NULL, ...) {
+random_mic <- function(size = NULL, mo = NULL, ab = NULL, skew = "right", severity = 1, ...) {
   meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
-  meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
+  meet_criteria(mo, allow_class = "character", has_length = c(1, size), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
+  meet_criteria(skew, allow_class = "character", is_in = c("right", "left"), has_length = 1)
+  meet_criteria(severity, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
+
   if (is.null(size)) {
     size <- NROW(get_current_data(arg_name = "size", call = -3))
   }
-  random_exec("MIC", size = size, mo = mo, ab = ab)
+  if (length(mo) > 1) {
+    out <- rep(NA_mic_, length(size))
+    p <- progress_ticker(n = length(unique(mo)), n_min = 10, title = "Generating random MIC values")
+    for (mo_ in unique(mo)) {
+      p$tick()
+      out[which(mo == mo_)] <- random_exec("MIC", size = sum(mo == mo_), mo = mo_, ab = ab, skew = skew, severity = severity)
+    }
+    out <- as.mic(out, keep_operators = "none")
+    if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
+      out[out == min(out)] <- paste0("<=", out[out == min(out)])
+    }
+    if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
+      out[out == max(out) & out %unlike% "<="] <- paste0(">=", out[out == max(out) & out %unlike% "<="])
+    }
+
+    return(out)
+  } else {
+    random_exec("MIC", size = size, mo = mo, ab = ab, skew = skew, severity = severity)
+  }
 }
 
 #' @rdname random
 #' @export
-random_disk <- function(size = NULL, mo = NULL, ab = NULL, ...) {
+random_disk <- function(size = NULL, mo = NULL, ab = NULL, skew = "left", severity = 1, ...) {
   meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
-  meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
+  meet_criteria(mo, allow_class = "character", has_length = c(1, size), allow_NULL = TRUE)
   meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
+  meet_criteria(skew, allow_class = "character", is_in = c("right", "left"), has_length = 1)
+  meet_criteria(severity, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
+
   if (is.null(size)) {
     size <- NROW(get_current_data(arg_name = "size", call = -3))
   }
-  random_exec("DISK", size = size, mo = mo, ab = ab)
+  if (length(mo) > 1) {
+    out <- rep(NA_mic_, length(size))
+    p <- progress_ticker(n = length(unique(mo)), n_min = 10, title = "Generating random MIC values")
+    for (mo_ in unique(mo)) {
+      p$tick()
+      out[which(mo == mo_)] <- random_exec("DISK", size = sum(mo == mo_), mo = mo_, ab = ab, skew = skew, severity = severity)
+    }
+    out <- as.disk(out)
+    return(out)
+  } else {
+    random_exec("DISK", size = size, mo = mo, ab = ab, skew = skew, severity = severity)
+  }
 }
 
 #' @rdname random
@@ -90,78 +134,60 @@ random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) {
   sample(as.sir(c("S", "I", "R")), size = size, replace = TRUE, prob = prob_SIR)
 }
 
-random_exec <- function(method_type, size, mo = NULL, ab = NULL) {
+
-  df <- AMR::clinical_breakpoints %pm>%
+random_exec <- function(method_type, size, mo = NULL, ab = NULL, skew = "right", severity = 1) {
-    pm_filter(guideline %like% "EUCAST") %pm>%
+  df <- AMR::clinical_breakpoints %pm>% subset(method == method_type & type == "human")
-    pm_arrange(pm_desc(guideline)) %pm>%
-    subset(guideline == max(guideline) &
-      method == method_type &
-      type == "human")
 
   if (!is.null(mo)) {
-    mo_coerced <- as.mo(mo)
+    mo_coerced <- as.mo(mo, info = FALSE)
-    mo_include <- c(
+    mo_include <- c(mo_coerced, as.mo(mo_genus(mo_coerced)), as.mo(mo_family(mo_coerced)), as.mo(mo_order(mo_coerced)))
-      mo_coerced,
+    df_new <- df %pm>% subset(mo %in% mo_include)
-      as.mo(mo_genus(mo_coerced)),
+    if (nrow(df_new) > 0) df <- df_new
-      as.mo(mo_family(mo_coerced)),
-      as.mo(mo_order(mo_coerced))
-    )
-    df_new <- df %pm>%
-      subset(mo %in% mo_include)
-    if (nrow(df_new) > 0) {
-      df <- df_new
-    } else {
-      warning_("in `random_", tolower(method_type), "()`: no rows found that match mo '", mo, "', ignoring argument `mo`")
-    }
   }
 
   if (!is.null(ab)) {
     ab_coerced <- as.ab(ab)
-    df_new <- df %pm>%
+    df_new <- df %pm>% subset(ab %in% ab_coerced)
-      subset(ab %in% ab_coerced)
+    if (nrow(df_new) > 0) df <- df_new
-    if (nrow(df_new) > 0) {
-      df <- df_new
-    } else {
-      warning_("in `random_", tolower(method_type), "()`: no rows found that match ab '", ab, "' (", ab_name(ab_coerced, tolower = TRUE, language = NULL), "), ignoring argument `ab`")
-    }
   }
 
   if (method_type == "MIC") {
-    # set range
+    lowest_mic <- min(df$breakpoint_S, na.rm = TRUE)
-    mic_range <- c(0.001, 0.002, 0.005, 0.010, 0.025, 0.0625, 0.125, 0.250, 0.5, 1, 2, 4, 8, 16, 32, 64, 128, 256)
+    lowest_mic <- log2(lowest_mic) + sample(c(-3:2), 1)
+    lowest_mic <- 2^lowest_mic
+    highest_mic <- max(df$breakpoint_R, na.rm = TRUE)
+    highest_mic <- log2(highest_mic) + sample(c(-3:1), 1)
+    highest_mic <- max(lowest_mic * 2, 2^highest_mic)
 
-    # get highest/lowest +/- random 1 to 3 higher factors of two
+    out <- skewed_values(COMMON_MIC_VALUES, size = size, min = lowest_mic, max = highest_mic, skew = skew, severity = severity)
-    max_range <- mic_range[min(
-      length(mic_range),
-      which(mic_range == max(df$breakpoint_R[!is.na(df$breakpoint_R)], na.rm = TRUE)) + sample(c(1:3), 1)
-    )]
-    min_range <- mic_range[max(
-      1,
-      which(mic_range == min(df$breakpoint_S, na.rm = TRUE)) - sample(c(1:3), 1)
-    )]
-
-    mic_range_new <- mic_range[mic_range <= max_range & mic_range >= min_range]
-    if (length(mic_range_new) == 0) {
-      mic_range_new <- mic_range
-    }
-    out <- as.mic(sample(mic_range_new, size = size, replace = TRUE))
-    # 50% chance that lowest will get <= and highest will get >=
     if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
       out[out == min(out)] <- paste0("<=", out[out == min(out)])
     }
     if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
-      out[out == max(out)] <- paste0(">=", out[out == max(out)])
+      out[out == max(out) & out %unlike% "<="] <- paste0(">=", out[out == max(out) & out %unlike% "<="])
     }
-    return(out)
+    return(as.mic(out))
   } else if (method_type == "DISK") {
-    set_range <- seq(
+    disk_range <- seq(
-      from = as.integer(min(df$breakpoint_R[!is.na(df$breakpoint_R)], na.rm = TRUE) / 1.25),
+      from = floor(min(df$breakpoint_R[!is.na(df$breakpoint_R)], na.rm = TRUE) / 1.25),
-      to = as.integer(max(df$breakpoint_S, na.rm = TRUE) * 1.25),
+      to = ceiling(max(df$breakpoint_S[df$breakpoint_S != 50], na.rm = TRUE) * 1.25),
       by = 1
     )
-    out <- sample(set_range, size = size, replace = TRUE)
+    disk_range <- disk_range[disk_range >= 6 & disk_range <= 50]
-    out[out < 6] <- sample(c(6:10), length(out[out < 6]), replace = TRUE)
+    out <- skewed_values(disk_range, size = size, min = min(disk_range), max = max(disk_range), skew = skew, severity = severity)
-    out[out > 50] <- sample(c(40:50), length(out[out > 50]), replace = TRUE)
     return(as.disk(out))
   }
 }
+
+skewed_values <- function(values, size, min, max, skew = c("right", "left"), severity = 1) {
+  skew <- match.arg(skew)
+  range_vals <- values[values >= min & values <= max]
+  if (length(range_vals) < 2) range_vals <- values
+  ranks <- seq_along(range_vals)
+  weights <- switch(skew,
+    right = rev(ranks)^severity,
+    left = ranks^severity
+  )
+  weights <- weights / sum(weights)
+  sample(range_vals, size = size, replace = TRUE, prob = weights)
+}

R/sir.R

@@ -69,7 +69,9 @@
 #' @param reference_data A [data.frame] to be used for interpretation, which defaults to the [clinical_breakpoints] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [clinical_breakpoints] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
 #' @param threshold Maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples*.
 #' @param conserve_capped_values Deprecated, use `capped_mic_handling` instead.
-#' @param ... For using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
+#' @param ... For using on a [data.frame]: selection of columns to apply `as.sir()` to. Supports [tidyselect language][tidyselect::starts_with()] such as `where(is.mic)`, `starts_with(...)`, or `column1:column4`, and can thus also be [antimicrobial selectors][amr_selector()] such as `as.sir(df, penicillins())`.
+#'
+#' Otherwise: arguments passed on to methods.
 #' @details
 #' *Note: The clinical breakpoints in this package were validated through, and imported from, [WHONET](https://whonet.org). The public use of this `AMR` package has been endorsed by both CLSI and EUCAST. See [clinical_breakpoints] for more information.*
 #'
@@ -159,7 +161,7 @@
 #'
 #' The function [is.sir()] detects if the input contains class `sir`. If the input is a [data.frame] or [list], it iterates over all columns/items and returns a [logical] vector.
 #'
-#' The base R function [as.double()] can be used to retrieve quantitative values from a `sir` object: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA` . **Note:** Do not use `as.integer()`, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
+#' The base R function [as.double()] can be used to retrieve quantitative values from a `sir` object: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA`. **Note:** Do not use `as.integer()`, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
 #'
 #' The function [is_sir_eligible()] returns `TRUE` when a column contains at most 5% potentially invalid antimicrobial interpretations, and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
 #' @section Interpretation of SIR:
@@ -225,9 +227,12 @@
 #'   df_wide %>% mutate_if(is.mic, as.sir)
 #'   df_wide %>% mutate_if(function(x) is.mic(x) | is.disk(x), as.sir)
 #'   df_wide %>% mutate(across(where(is.mic), as.sir))
+#'
 #'   df_wide %>% mutate_at(vars(amoxicillin:tobra), as.sir)
 #'   df_wide %>% mutate(across(amoxicillin:tobra, as.sir))
 #'
+#'   df_wide %>% mutate(across(aminopenicillins(), as.sir))
+#'
 #'   # approaches that all work with additional arguments:
 #'   df_long %>%
 #'     # given a certain data type, e.g. MIC values
@@ -722,8 +727,17 @@ as.sir.data.frame <- function(x,
   meet_criteria(info, allow_class = "logical", has_length = 1)
   meet_criteria(parallel, allow_class = "logical", has_length = 1)
   meet_criteria(max_cores, allow_class = c("numeric", "integer"), has_length = 1)
-
   x.bak <- x
+
+  if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
+    sel <- colnames(pm_select(x, ...))
+  } else {
+    sel <- colnames(x)
+  }
+  if (!is.null(col_mo)) {
+    sel <- sel[sel != col_mo]
+  }
+
   for (i in seq_len(ncol(x))) {
     # don't keep factors, overwriting them is hard
     if (is.factor(x[, i, drop = TRUE])) {
@@ -803,15 +817,6 @@ as.sir.data.frame <- function(x,
   }
 
   i <- 0
-  if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
-    sel <- colnames(pm_select(x, ...))
-  } else {
-    sel <- colnames(x)
-  }
-  if (!is.null(col_mo)) {
-    sel <- sel[sel != col_mo]
-  }
-
   ab_cols <- colnames(x)[vapply(FUN.VALUE = logical(1), x, function(y) {
     i <<- i + 1
     check <- is.mic(y) | is.disk(y)
@@ -863,7 +868,7 @@ as.sir.data.frame <- function(x,
     cl <- tryCatch(parallel::makeCluster(n_cores, type = "PSOCK"),
       error = function(e) {
         if (isTRUE(info)) {
-          message_("Could not create parallel cluster, using single-core computation. Error message: ", e$message, add_fn = font_red)
+          message_("Could not create parallel cluster, using single-core computation. Error message: ", conditionMessage(e), add_fn = font_red)
         }
         return(NULL)
       }
@@ -1904,11 +1909,11 @@ pillar_shaft.sir <- function(x, ...) {
     # colours will anyway not work when has_colour() == FALSE,
     # but then the indentation should also not be applied
     out[is.na(x)] <- font_grey("  NA")
-    out[x == "NI"] <- font_grey_bg(font_black("  NI "))
     out[x == "S"] <- font_green_bg("  S  ")
+    out[x == "SDD"] <- font_green_lighter_bg(" SDD ")
     out[x == "I"] <- font_orange_bg("  I  ")
-    out[x == "SDD"] <- font_orange_bg(" SDD ")
     out[x == "R"] <- font_rose_bg("  R  ")
+    out[x == "NI"] <- font_grey_bg(font_black("  NI "))
   }
   create_pillar_column(out, align = "left", width = 5)
 }

R/sir_calc.R

@@ -244,7 +244,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
   translate_ab <- get_translate_ab(translate_ab)
 
   data.bak <- data
-  # select only groups and antimicrobials
+  # select only groups and antibiotics
   if (is_null_or_grouped_tbl(data)) {
     data_has_groups <- TRUE
     groups <- get_group_names(data)
@@ -255,15 +255,14 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
   }
 
   data <- as.data.frame(data, stringsAsFactors = FALSE)
-  if (isTRUE(combine_SI)) {
+
-    for (i in seq_len(ncol(data))) {
+  for (i in seq_len(ncol(data))) {
-      if (is.sir(data[, i, drop = TRUE])) {
+    data[, i] <- as.character(as.sir(data[, i, drop = TRUE]))
-        data[, i] <- as.character(data[, i, drop = TRUE])
+    if (isTRUE(combine_SI)) {
-        if ("SDD" %in% data[, i, drop = TRUE] && message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
+      if ("SDD" %in% data[, i, drop = TRUE] && message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
-          message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
+        message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
-        }
-        data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
       }
+      data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
     }
   }
 
@@ -364,7 +363,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
   } else {
     # don't use as.sir() here, as it would add the class 'sir' and we would like
     # the same data structure as output, regardless of input
-    if (out$value[out$interpretation == "SDD"] > 0) {
+    if (any(out$value[out$interpretation == "SDD"] > 0, na.rm = TRUE)) {
       out$interpretation <- factor(out$interpretation, levels = c("S", "SDD", "I", "R"), ordered = TRUE)
     } else {
       out$interpretation <- factor(out$interpretation, levels = c("S", "I", "R"), ordered = TRUE)

R/sir_df.R

@@ -47,6 +47,6 @@ sir_df <- function(data,
       combine_SI = combine_SI,
       confidence_level = confidence_level
     ),
-    error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
+    error = function(e) stop_(gsub("in sir_calc_df(): ", "", conditionMessage(e), fixed = TRUE), call = -5)
   )
 }

R/tidymodels.R

@@ -0,0 +1,262 @@
+#' AMR Extensions for Tidymodels
+#'
+#' This family of functions allows using AMR-specific data types such as `<mic>` and `<sir>` inside `tidymodels` pipelines.
+#' @inheritParams recipes::step_center
+#' @details
+#' You can read more in our online [AMR with tidymodels introduction](https://amr-for-r.org/articles/AMR_with_tidymodels.html).
+#'
+#' Tidyselect helpers include:
+#' - [all_mic()] and [all_mic_predictors()] to select `<mic>` columns
+#' - [all_sir()] and [all_sir_predictors()] to select `<sir>` columns
+#'
+#' Pre-processing pipeline steps include:
+#' - [step_mic_log2()] to convert MIC columns to numeric (via `as.numeric()`) and apply a log2 transform, to be used with [all_mic_predictors()]
+#' - [step_sir_numeric()] to convert SIR columns to numeric (via `as.numeric()`), to be used with [all_sir_predictors()]: `"S"` = 1, `"I"`/`"SDD"` = 2, `"R"` = 3. All other values are rendered `NA`. Keep this in mind for further processing, especially if the model does not allow for `NA` values.
+#'
+#' These steps integrate with `recipes::recipe()` and work like standard preprocessing steps. They are useful for preparing data for modelling, especially with classification models.
+#' @seealso [recipes::recipe()], [as.mic()], [as.sir()]
+#' @name amr-tidymodels
+#' @keywords internal
+#' @export
+#' @examples
+#' library(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.
+#'
+#'
+#' # 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))
+#'
+#' # 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()
+#'
+#' # View prepped recipe
+#' mic_recipe
+#'
+#' # 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)
+#'
+#' # 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:
+#' # - negative predictive value (NPV) of ~98%
+#' # - positive predictive value (PPV) of ~94%
+#' metrics
+all_mic <- function() {
+  x <- tidymodels_amr_select(levels(NA_mic_))
+  names(x)
+}
+
+#' @rdname amr-tidymodels
+#' @export
+all_mic_predictors <- function() {
+  x <- tidymodels_amr_select(levels(NA_mic_))
+  intersect(x, recipes::has_role("predictor"))
+}
+
+#' @rdname amr-tidymodels
+#' @export
+all_sir <- function() {
+  x <- tidymodels_amr_select(levels(NA_sir_))
+  names(x)
+}
+
+#' @rdname amr-tidymodels
+#' @export
+all_sir_predictors <- function() {
+  x <- tidymodels_amr_select(levels(NA_sir_))
+  intersect(x, recipes::has_role("predictor"))
+}
+
+#' @rdname amr-tidymodels
+#' @export
+step_mic_log2 <- function(
+    recipe,
+    ...,
+    role = NA,
+    trained = FALSE,
+    columns = NULL,
+    skip = FALSE,
+    id = recipes::rand_id("mic_log2")) {
+  recipes::add_step(
+    recipe,
+    step_mic_log2_new(
+      terms = rlang::enquos(...),
+      role = role,
+      trained = trained,
+      columns = columns,
+      skip = skip,
+      id = id
+    )
+  )
+}
+
+step_mic_log2_new <- function(terms, role, trained, columns, skip, id) {
+  recipes::step(
+    subclass = "mic_log2",
+    terms = terms,
+    role = role,
+    trained = trained,
+    columns = columns,
+    skip = skip,
+    id = id
+  )
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::prep, step_mic_log2)
+prep.step_mic_log2 <- function(x, training, info = NULL, ...) {
+  col_names <- recipes::recipes_eval_select(x$terms, training, info)
+  recipes::check_type(training[, col_names], types = "ordered")
+  step_mic_log2_new(
+    terms = x$terms,
+    role = x$role,
+    trained = TRUE,
+    columns = col_names,
+    skip = x$skip,
+    id = x$id
+  )
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::bake, step_mic_log2)
+bake.step_mic_log2 <- function(object, new_data, ...) {
+  recipes::check_new_data(object$columns, object, new_data)
+  for (col in object$columns) {
+    new_data[[col]] <- log2(as.numeric(as.mic(new_data[[col]])))
+  }
+  new_data
+}
+
+#' @export
+print.step_mic_log2 <- function(x, width = max(20, options()$width - 35), ...) {
+  title <- "Log2 transformation of MIC columns"
+  recipes::print_step(x$columns, x$terms, x$trained, title, width)
+  invisible(x)
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::tidy, step_mic_log2)
+tidy.step_mic_log2 <- function(x, ...) {
+  if (recipes::is_trained(x)) {
+    res <- tibble::tibble(terms = x$columns)
+  } else {
+    res <- tibble::tibble(terms = recipes::sel2char(x$terms))
+  }
+  res$id <- x$id
+  res
+}
+
+#' @rdname amr-tidymodels
+#' @export
+step_sir_numeric <- function(
+    recipe,
+    ...,
+    role = NA,
+    trained = FALSE,
+    columns = NULL,
+    skip = FALSE,
+    id = recipes::rand_id("sir_numeric")) {
+  recipes::add_step(
+    recipe,
+    step_sir_numeric_new(
+      terms = rlang::enquos(...),
+      role = role,
+      trained = trained,
+      columns = columns,
+      skip = skip,
+      id = id
+    )
+  )
+}
+
+step_sir_numeric_new <- function(terms, role, trained, columns, skip, id) {
+  recipes::step(
+    subclass = "sir_numeric",
+    terms = terms,
+    role = role,
+    trained = trained,
+    columns = columns,
+    skip = skip,
+    id = id
+  )
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::prep, step_sir_numeric)
+prep.step_sir_numeric <- function(x, training, info = NULL, ...) {
+  col_names <- recipes::recipes_eval_select(x$terms, training, info)
+  recipes::check_type(training[, col_names], types = "ordered")
+  step_sir_numeric_new(
+    terms = x$terms,
+    role = x$role,
+    trained = TRUE,
+    columns = col_names,
+    skip = x$skip,
+    id = x$id
+  )
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::bake, step_sir_numeric)
+bake.step_sir_numeric <- function(object, new_data, ...) {
+  recipes::check_new_data(object$columns, object, new_data)
+  for (col in object$columns) {
+    new_data[[col]] <- as.numeric(as.sir(new_data[[col]]))
+  }
+  new_data
+}
+
+#' @export
+print.step_sir_numeric <- function(x, width = max(20, options()$width - 35), ...) {
+  title <- "Numeric transformation of SIR columns"
+  recipes::print_step(x$columns, x$terms, x$trained, title, width)
+  invisible(x)
+}
+
+#' @rawNamespace if(getRversion() >= "3.0.0") S3method(recipes::tidy, step_sir_numeric)
+tidy.step_sir_numeric <- function(x, ...) {
+  if (recipes::is_trained(x)) {
+    res <- tibble::tibble(terms = x$columns)
+  } else {
+    res <- tibble::tibble(terms = recipes::sel2char(x$terms))
+  }
+  res$id <- x$id
+  res
+}
+
+tidymodels_amr_select <- function(check_vector) {
+  df <- get_current_data()
+  ind <- which(
+    vapply(
+      FUN.VALUE = logical(1),
+      df,
+      function(x) all(x %in% c(check_vector, NA), na.rm = TRUE) & any(x %in% check_vector),
+      USE.NAMES = TRUE
+    ),
+    useNames = TRUE
+  )
+  ind
+}

R/translate.R

@@ -258,6 +258,11 @@ translate_into_language <- function(from,
     return(from)
   }
 
+  if (only_affect_ab_names == TRUE) {
+    df_trans$pattern[df_trans$regular_expr == TRUE] <- paste0(df_trans$pattern[df_trans$regular_expr == TRUE], "$")
+    df_trans$pattern[df_trans$regular_expr == TRUE] <- gsub("$$", "$", df_trans$pattern[df_trans$regular_expr == TRUE], fixed = TRUE)
+  }
+
   lapply(
     # starting with longest pattern, since more general translations are shorter, such as 'Group'
     order(nchar(df_trans$pattern), decreasing = TRUE),

R/vctrs.R

@@ -30,7 +30,6 @@
 # These are all S3 implementations for the vctrs package,
 # that is used internally by tidyverse packages such as dplyr.
 # They are to convert AMR-specific classes to bare characters and integers.
-# All of them will be exported using s3_register() in R/zzz.R when loading the package.
 
 # see https://github.com/tidyverse/dplyr/issues/5955 why this is required
 

R/zzz.R

@@ -127,7 +127,7 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
           suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
           packageStartupMessage("OK.")
         },
-        error = function(e) packageStartupMessage("Failed: ", e$message)
+        error = function(e) packageStartupMessage("Failed: ", conditionMessage(e))
       )
     }
   }
@@ -143,7 +143,7 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
           suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
           packageStartupMessage("OK.")
         },
-        error = function(e) packageStartupMessage("Failed: ", e$message)
+        error = function(e) packageStartupMessage("Failed: ", conditionMessage(e))
       )
     }
   }

_pkgdown.yml

@@ -234,6 +234,7 @@ reference:
     - "`antimicrobials`"
     - "`clinical_breakpoints`"
     - "`example_isolates`"
+    - "`esbl_isolates`"
     - "`microorganisms.codes`"
     - "`microorganisms.groups`"
     - "`intrinsic_resistant`"

data-raw/_pre_commit_checks.R

@@ -663,7 +663,9 @@ if (files_changed()) {
 }
 
 # Update index.md and README.md -------------------------------------------
-if (files_changed("man/microorganisms.Rd") ||
+if (files_changed("README.Rmd") ||
+    files_changed("index.Rmd") ||
+    files_changed("man/microorganisms.Rd") ||
     files_changed("man/antimicrobials.Rd") ||
     files_changed("man/clinical_breakpoints.Rd") ||
     files_changed("man/antibiogram.Rd") ||

data-raw/_reproduction_scripts/reproduction_of_microorganisms.R

@@ -288,7 +288,7 @@ for (page in LETTERS) {
   url <- paste0("https://lpsn.dsmz.de/genus?page=", page)
   x <- tryCatch(read_html(url),
                 error = function(e) {
-                  message("Waiting 10 seconds because of error: ", e$message)
+                  message("Waiting 10 seconds because of error: ", conditionMessage(e))
                   Sys.sleep(10)
                   read_html(url)
                 })

data-raw/_reproduction_scripts/reproduction_of_poorman.R

@@ -108,3 +108,18 @@ writeLines(contents, "R/aa_helper_pm_functions.R")
 
 # note: pm_left_join() will be overwritten by aaa_helper_functions.R, which contains a faster implementation
 # replace `res <- as.data.frame(res)` with  `res <- as.data.frame(res, stringsAsFactors = FALSE)`
+
+# after running, pm_select must be altered. The line:
+# col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
+# ... must be replaced with this to support tidyselect functionality such as `starts_with()`:
+# col_pos <- tryCatch(pm_select_positions(.data, ..., .group_pos = TRUE), error = function(e) NULL)
+# if (is.null(col_pos)) {
+#   # try with tidyverse
+#   select_dplyr <- import_fn("select", "dplyr", error_on_fail = FALSE)
+#   if (!is.null(select_dplyr)) {
+#     col_pos <- which(colnames(.data) %in% colnames(select_dplyr(.data, ...)))
+#   } else {
+#     # this will throw an error as it did, but dplyr is not available, so no other option
+#     col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
+#   }
+# }

data-raw/read_EUCAST.R

@@ -283,7 +283,7 @@ for (i in 2:length(sheets_to_analyse)) {
         guideline_name = guideline_name
       )
     ),
-    error = function(e) message(e$message)
+    error = function(e) message(conditionMessage(e))
   )
 }
 

index.Rmd

@@ -28,8 +28,8 @@ AMR:::reset_all_thrown_messages()
 > Now available for Python too! [Click here](./articles/AMR_for_Python.html) to read more.
 
 <div style="display: flex; font-size: 0.8em;">
-  <p style="text-align:left; width: 50%;"><small><a href="https://amr-for-r.org/">https://amr-for-r.org</a></small></p>
+  <p style="text-align:left; width: 50%;"><small><a href="https://amr-for-r.org/">amr-for-r.org</a></small></p>
-  <p style="text-align:right; width: 50%;"><small><a href="https://doi.org/10.18637/jss.v104.i03" target="_blank">https://doi.org/10.18637/jss.v104.i03</a></small></p>
+  <p style="text-align:right; width: 50%;"><small><a href="https://doi.org/10.18637/jss.v104.i03" target="_blank">doi.org/10.18637/jss.v104.i03</a></small></p>
 </div>
 
 <a href="./reference/clinical_breakpoints.html#response-from-clsi-and-eucast"><img src="./endorsement_clsi_eucast.jpg" class="endorse_img" align="right" height="120" /></a>

index.md

@@ -27,12 +27,12 @@
 
 <p style="text-align:left; width: 50%;">
 
-<small><a href="https://amr-for-r.org/">https://amr-for-r.org</a></small>
+<small><a href="https://amr-for-r.org/">amr-for-r.org</a></small>
 </p>
 
 <p style="text-align:right; width: 50%;">
 
-<small><a href="https://doi.org/10.18637/jss.v104.i03" target="_blank">https://doi.org/10.18637/jss.v104.i03</a></small>
+<small><a href="https://doi.org/10.18637/jss.v104.i03" target="_blank">doi.org/10.18637/jss.v104.i03</a></small>
 </p>
 
 </div>
@@ -321,9 +321,9 @@ example_isolates %>%
 #> # A tibble: 3 × 5
 #>   ward       GEN_total_R GEN_conf_int TOB_total_R TOB_conf_int
 #>   <chr>            <dbl> <chr>              <dbl> <chr>       
-#> 1 Clinical     0.2289362 0.205-0.254    0.3147503 0.284-0.347 
+#> 1 Clinical         0.229 0.205-0.254        0.315 0.284-0.347 
-#> 2 ICU          0.2902655 0.253-0.33     0.4004739 0.353-0.449 
+#> 2 ICU              0.290 0.253-0.33         0.400 0.353-0.449 
-#> 3 Outpatient   0.2       0.131-0.285    0.3676471 0.254-0.493
+#> 3 Outpatient       0.2   0.131-0.285        0.368 0.254-0.493
 ```
 
 Or use [antimicrobial
@@ -351,33 +351,33 @@ out <- example_isolates %>%
 #> "Outpatient" (minimum = 30).
 out
 #> # A tibble: 3 × 6
-#>   ward             GEN       TOB       AMK   KAN       COL
+#>   ward         GEN   TOB   AMK   KAN   COL
-#>   <chr>          <dbl>     <dbl>     <dbl> <dbl>     <dbl>
+#>   <chr>      <dbl> <dbl> <dbl> <dbl> <dbl>
-#> 1 Clinical   0.2289362 0.3147503 0.6258993     1 0.7802956
+#> 1 Clinical   0.229 0.315 0.626     1 0.780
-#> 2 ICU        0.2902655 0.4004739 0.6624473     1 0.8574144
+#> 2 ICU        0.290 0.400 0.662     1 0.857
-#> 3 Outpatient 0.2       0.3676471 0.6052632    NA 0.8888889
+#> 3 Outpatient 0.2   0.368 0.605    NA 0.889
 ```
 
 ``` r
 # transform the antibiotic columns to names:
 out %>% set_ab_names()
 #> # A tibble: 3 × 6
-#>   ward       gentamicin tobramycin  amikacin kanamycin  colistin
+#>   ward       gentamicin tobramycin amikacin kanamycin colistin
-#>   <chr>           <dbl>      <dbl>     <dbl>     <dbl>     <dbl>
+#>   <chr>           <dbl>      <dbl>    <dbl>     <dbl>    <dbl>
-#> 1 Clinical    0.2289362  0.3147503 0.6258993         1 0.7802956
+#> 1 Clinical        0.229      0.315    0.626         1    0.780
-#> 2 ICU         0.2902655  0.4004739 0.6624473         1 0.8574144
+#> 2 ICU             0.290      0.400    0.662         1    0.857
-#> 3 Outpatient  0.2        0.3676471 0.6052632        NA 0.8888889
+#> 3 Outpatient      0.2        0.368    0.605        NA    0.889
 ```
 
 ``` r
 # transform the antibiotic column to ATC codes:
 out %>% set_ab_names(property = "atc")
 #> # A tibble: 3 × 6
-#>   ward         J01GB03   J01GB01   J01GB06 J01GB04   J01XB01
+#>   ward       J01GB03 J01GB01 J01GB06 J01GB04 J01XB01
-#>   <chr>          <dbl>     <dbl>     <dbl>   <dbl>     <dbl>
+#>   <chr>        <dbl>   <dbl>   <dbl>   <dbl>   <dbl>
-#> 1 Clinical   0.2289362 0.3147503 0.6258993       1 0.7802956
+#> 1 Clinical     0.229   0.315   0.626       1   0.780
-#> 2 ICU        0.2902655 0.4004739 0.6624473       1 0.8574144
+#> 2 ICU          0.290   0.400   0.662       1   0.857
-#> 3 Outpatient 0.2       0.3676471 0.6052632      NA 0.8888889
+#> 3 Outpatient   0.2     0.368   0.605      NA   0.889
 ```
 
 ## What else can you do with this package?

man/amr-tidymodels.Rd

@@ -0,0 +1,122 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidymodels.R
+\name{amr-tidymodels}
+\alias{amr-tidymodels}
+\alias{all_mic}
+\alias{all_mic_predictors}
+\alias{all_sir}
+\alias{all_sir_predictors}
+\alias{step_mic_log2}
+\alias{step_sir_numeric}
+\title{AMR Extensions for Tidymodels}
+\usage{
+all_mic()
+
+all_mic_predictors()
+
+all_sir()
+
+all_sir_predictors()
+
+step_mic_log2(recipe, ..., role = NA, trained = FALSE, columns = NULL,
+  skip = FALSE, id = recipes::rand_id("mic_log2"))
+
+step_sir_numeric(recipe, ..., role = NA, trained = FALSE, columns = NULL,
+  skip = FALSE, id = recipes::rand_id("sir_numeric"))
+}
+\arguments{
+\item{recipe}{A recipe object. The step will be added to the sequence of
+operations for this recipe.}
+
+\item{...}{One or more selector functions to choose variables for this step.
+See \code{\link[recipes:selections]{selections()}} for more details.}
+
+\item{role}{Not used by this step since no new variables are created.}
+
+\item{trained}{A logical to indicate if the quantities for preprocessing have
+been estimated.}
+
+\item{skip}{A logical. Should the step be skipped when the recipe is baked by
+\code{\link[recipes:bake]{bake()}}? While all operations are baked when \code{\link[recipes:prep]{prep()}} is run, some
+operations may not be able to be conducted on new data (e.g. processing the
+outcome variable(s)). Care should be taken when using \code{skip = TRUE} as it
+may affect the computations for subsequent operations.}
+
+\item{id}{A character string that is unique to this step to identify it.}
+}
+\description{
+This family of functions allows using AMR-specific data types such as \verb{<mic>} and \verb{<sir>} inside \code{tidymodels} pipelines.
+}
+\details{
+You can read more in our online \href{https://amr-for-r.org/articles/AMR_with_tidymodels.html}{AMR with tidymodels introduction}.
+
+Tidyselect helpers include:
+\itemize{
+\item \code{\link[=all_mic]{all_mic()}} and \code{\link[=all_mic_predictors]{all_mic_predictors()}} to select \verb{<mic>} columns
+\item \code{\link[=all_sir]{all_sir()}} and \code{\link[=all_sir_predictors]{all_sir_predictors()}} to select \verb{<sir>} columns
+}
+
+Pre-processing pipeline steps include:
+\itemize{
+\item \code{\link[=step_mic_log2]{step_mic_log2()}} to convert MIC columns to numeric (via \code{as.numeric()}) and apply a log2 transform, to be used with \code{\link[=all_mic_predictors]{all_mic_predictors()}}
+\item \code{\link[=step_sir_numeric]{step_sir_numeric()}} to convert SIR columns to numeric (via \code{as.numeric()}), to be used with \code{\link[=all_sir_predictors]{all_sir_predictors()}}: \code{"S"} = 1, \code{"I"}/\code{"SDD"} = 2, \code{"R"} = 3. All other values are rendered \code{NA}. Keep this in mind for further processing, especially if the model does not allow for \code{NA} values.
+}
+
+These steps integrate with \code{recipes::recipe()} and work like standard preprocessing steps. They are useful for preparing data for modelling, especially with classification models.
+}
+\examples{
+library(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.
+
+
+# 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))
+
+# 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()
+
+# View prepped recipe
+mic_recipe
+
+# 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)
+
+# 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:
+# - negative predictive value (NPV) of ~98\%
+# - positive predictive value (PPV) of ~94\%
+metrics
+}
+\seealso{
+\code{\link[recipes:recipe]{recipes::recipe()}}, \code{\link[=as.mic]{as.mic()}}, \code{\link[=as.sir]{as.sir()}}
+}
+\keyword{internal}

man/antibiogram.Rd

@@ -56,6 +56,7 @@ retrieve_wisca_parameters(wisca_model, ...)
 \item \code{c(aminoglycosides(), "AMP", "AMC")}
 \item \code{c(aminoglycosides(), carbapenems())}
 }
+\item Column indices using numbers
 \item Combination therapy, indicated by using \code{"+"}, with or without \link[=antimicrobial_selectors]{antimicrobial selectors}, e.g.:
 \itemize{
 \item \code{"cipro + genta"}

man/as.sir.Rd

@@ -75,7 +75,9 @@ sir_interpretation_history(clean = FALSE)
 \arguments{
 \item{x}{Vector of values (for class \code{\link{mic}}: MIC values in mg/L, for class \code{\link{disk}}: a disk diffusion radius in millimetres).}
 
-\item{...}{For using on a \link{data.frame}: names of columns to apply \code{\link[=as.sir]{as.sir()}} on (supports tidy selection such as \code{column1:column4}). Otherwise: arguments passed on to methods.}
+\item{...}{For using on a \link{data.frame}: selection of columns to apply \code{as.sir()} to. Supports \link[tidyselect:starts_with]{tidyselect language} such as \code{where(is.mic)}, \code{starts_with(...)}, or \code{column1:column4}, and can thus also be \link[=amr_selector]{antimicrobial selectors} such as \code{as.sir(df, penicillins())}.
+
+Otherwise: arguments passed on to methods.}
 
 \item{threshold}{Maximum fraction of invalid antimicrobial interpretations of \code{x}, see \emph{Examples}.}
 
@@ -247,7 +249,7 @@ To determine which isolates are multi-drug resistant, be sure to run \code{\link
 
 The function \code{\link[=is.sir]{is.sir()}} detects if the input contains class \code{sir}. If the input is a \link{data.frame} or \link{list}, it iterates over all columns/items and returns a \link{logical} vector.
 
-The base R function \code{\link[=as.double]{as.double()}} can be used to retrieve quantitative values from a \code{sir} object: \code{"S"} = 1, \code{"I"}/\code{"SDD"} = 2, \code{"R"} = 3. All other values are rendered \code{NA} . \strong{Note:} Do not use \code{as.integer()}, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
+The base R function \code{\link[=as.double]{as.double()}} can be used to retrieve quantitative values from a \code{sir} object: \code{"S"} = 1, \code{"I"}/\code{"SDD"} = 2, \code{"R"} = 3. All other values are rendered \code{NA}. \strong{Note:} Do not use \code{as.integer()}, since that (because of how R works internally) will return the factor level indices, and not these aforementioned quantitative values.
 
 The function \code{\link[=is_sir_eligible]{is_sir_eligible()}} returns \code{TRUE} when a column contains at most 5\% potentially invalid antimicrobial interpretations, and \code{FALSE} otherwise. The threshold of 5\% can be set with the \code{threshold} argument. If the input is a \link{data.frame}, it iterates over all columns and returns a \link{logical} vector.
 }
@@ -314,9 +316,12 @@ if (require("dplyr")) {
   df_wide \%>\% mutate_if(is.mic, as.sir)
   df_wide \%>\% mutate_if(function(x) is.mic(x) | is.disk(x), as.sir)
   df_wide \%>\% mutate(across(where(is.mic), as.sir))
+
   df_wide \%>\% mutate_at(vars(amoxicillin:tobra), as.sir)
   df_wide \%>\% mutate(across(amoxicillin:tobra, as.sir))
 
+  df_wide \%>\% mutate(across(aminopenicillins(), as.sir))
+
   # approaches that all work with additional arguments:
   df_long \%>\%
     # given a certain data type, e.g. MIC values

man/esbl_isolates.Rd

@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{esbl_isolates}
+\alias{esbl_isolates}
+\title{Data Set with 500 ESBL Isolates}
+\format{
+A \link[tibble:tibble]{tibble} with 500 observations and 19 variables:
+\itemize{
+\item \code{esbl}\cr Logical indicator if the isolate is ESBL-producing
+\item \code{genus}\cr Genus of the microorganism
+\item \code{AMC:COL}\cr MIC values for 17 antimicrobial agents, transformed to class \code{\link{mic}} (see \code{\link[=as.mic]{as.mic()}})
+}
+}
+\usage{
+esbl_isolates
+}
+\description{
+A data set containing 500 microbial isolates with MIC values of common antibiotics and a binary \code{esbl} column for extended-spectrum beta-lactamase (ESBL) production. This data set contains randomised fictitious data but reflects reality and can be used to practise AMR-related machine learning, e.g., classification modelling with \href{https://amr-for-r.org/articles/AMR_with_tidymodels.html}{tidymodels}.
+}
+\details{
+See our \link[=amr-tidymodels]{tidymodels integration} for an example using this data set.
+}
+\examples{
+esbl_isolates
+}
+\keyword{datasets}

man/ggplot_sir.Rd

@@ -9,10 +9,10 @@ ggplot_sir(data, position = NULL, x = "antibiotic",
   fill = "interpretation", facet = NULL, breaks = seq(0, 1, 0.1),
   limits = NULL, translate_ab = "name", combine_SI = TRUE,
   minimum = 30, language = get_AMR_locale(), nrow = NULL, colours = c(S
-  = "#3CAEA3", SI = "#3CAEA3", I = "#F6D55C", IR = "#ED553B", R = "#ED553B"),
+  = "#3CAEA3", SI = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", IR = "#ED553B",
-  datalabels = TRUE, datalabels.size = 2.5, datalabels.colour = "grey15",
+  R = "#ED553B"), datalabels = TRUE, datalabels.size = 2.5,
-  title = NULL, subtitle = NULL, caption = NULL,
+  datalabels.colour = "grey15", title = NULL, subtitle = NULL,
-  x.title = "Antimicrobial", y.title = "Proportion", ...)
+  caption = NULL, x.title = "Antimicrobial", y.title = "Proportion", ...)
 
 geom_sir(position = NULL, x = c("antibiotic", "interpretation"),
   fill = "interpretation", translate_ab = "name", minimum = 30,

man/mean_amr_distance.Rd

@@ -18,7 +18,7 @@ amr_distance_from_row(amr_distance, row)
 \arguments{
 \item{x}{A vector of class \link[=as.sir]{sir}, \link[=as.mic]{mic} or \link[=as.disk]{disk}, or a \link{data.frame} containing columns of any of these classes.}
 
-\item{...}{Variables to select. Supports \link[tidyselect:language]{tidyselect language} (such as \code{column1:column4} and \code{where(is.mic)}), and can thus also be \link[=amr_selector]{antimicrobial selectors}.}
+\item{...}{Variables to select. Supports \link[tidyselect:starts_with]{tidyselect language} such as \code{where(is.mic)}, \code{starts_with(...)}, or \code{column1:column4}, and can thus also be \link[=amr_selector]{antimicrobial selectors}.}
 
 \item{combine_SI}{A \link{logical} to indicate whether all values of S, SDD, and I must be merged into one, so the input only consists of S+I vs. R (susceptible vs. resistant) - the default is \code{TRUE}.}
 

man/plot.Rd

@@ -33,25 +33,25 @@ scale_colour_mic(keep_operators = "edges", mic_range = NULL, ...)
 
 scale_fill_mic(keep_operators = "edges", mic_range = NULL, ...)
 
-scale_x_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_x_sir(colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R
-  language = get_AMR_locale(), eucast_I = getOption("AMR_guideline",
+  = "#ED553B"), language = get_AMR_locale(),
-  "EUCAST") == "EUCAST", ...)
+  eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST", ...)
 
-scale_colour_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_colour_sir(colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I =
-  language = get_AMR_locale(), eucast_I = getOption("AMR_guideline",
+  "#F6D55C", R = "#ED553B"), language = get_AMR_locale(),
-  "EUCAST") == "EUCAST", ...)
+  eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST", ...)
 
-scale_fill_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+scale_fill_sir(colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C",
-  language = get_AMR_locale(), eucast_I = getOption("AMR_guideline",
+  R = "#ED553B"), language = get_AMR_locale(),
-  "EUCAST") == "EUCAST", ...)
+  eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST", ...)
 
 \method{plot}{mic}(x, mo = NULL, ab = NULL,
   guideline = getOption("AMR_guideline", "EUCAST"),
   main = deparse(substitute(x)), ylab = translate_AMR("Frequency", language
   = language),
   xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language =
-  language), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+  language), colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R
-  language = get_AMR_locale(), expand = TRUE,
+  = "#ED553B"), language = get_AMR_locale(), expand = TRUE,
   include_PKPD = getOption("AMR_include_PKPD", TRUE),
   breakpoint_type = getOption("AMR_breakpoint_type", "human"), ...)
 
@@ -60,8 +60,8 @@ scale_fill_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
   title = deparse(substitute(object)), ylab = translate_AMR("Frequency",
   language = language),
   xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language =
-  language), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+  language), colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R
-  language = get_AMR_locale(), expand = TRUE,
+  = "#ED553B"), language = get_AMR_locale(), expand = TRUE,
   include_PKPD = getOption("AMR_include_PKPD", TRUE),
   breakpoint_type = getOption("AMR_breakpoint_type", "human"), ...)
 
@@ -69,8 +69,8 @@ scale_fill_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
   ylab = translate_AMR("Frequency", language = language),
   xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
   mo = NULL, ab = NULL, guideline = getOption("AMR_guideline", "EUCAST"),
-  colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+  colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R =
-  language = get_AMR_locale(), expand = TRUE,
+  "#ED553B"), language = get_AMR_locale(), expand = TRUE,
   include_PKPD = getOption("AMR_include_PKPD", TRUE),
   breakpoint_type = getOption("AMR_breakpoint_type", "human"), ...)
 
@@ -78,8 +78,8 @@ scale_fill_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
   title = deparse(substitute(object)), ylab = translate_AMR("Frequency",
   language = language), xlab = translate_AMR("Disk diffusion diameter (mm)",
   language = language), guideline = getOption("AMR_guideline", "EUCAST"),
-  colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+  colours_SIR = c(S = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R =
-  language = get_AMR_locale(), expand = TRUE,
+  "#ED553B"), language = get_AMR_locale(), expand = TRUE,
   include_PKPD = getOption("AMR_include_PKPD", TRUE),
   breakpoint_type = getOption("AMR_breakpoint_type", "human"), ...)
 
@@ -90,8 +90,8 @@ scale_fill_sir(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
 
 \method{autoplot}{sir}(object, title = deparse(substitute(object)),
   xlab = translate_AMR("Antimicrobial Interpretation", language = language),
-  ylab = translate_AMR("Frequency", language = language),
+  ylab = translate_AMR("Frequency", language = language), colours_SIR = c(S
-  colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
+  = "#3CAEA3", SDD = "#8FD6C4", I = "#F6D55C", R = "#ED553B"),
   language = get_AMR_locale(), ...)
 
 facet_sir(facet = c("interpretation", "antibiotic"), nrow = NULL)
@@ -99,8 +99,8 @@ facet_sir(facet = c("interpretation", "antibiotic"), nrow = NULL)
 scale_y_percent(breaks = function(x) seq(0, max(x, na.rm = TRUE), 0.1),
   limits = c(0, NA))
 
-scale_sir_colours(..., aesthetics, colours_SIR = c("#3CAEA3", "#F6D55C",
+scale_sir_colours(..., aesthetics, colours_SIR = c(S = "#3CAEA3", SDD =
-  "#ED553B"))
+  "#8FD6C4", I = "#F6D55C", R = "#ED553B"))
 
 theme_sir()
 

man/random.Rd

@@ -7,19 +7,25 @@
 \alias{random_sir}
 \title{Random MIC Values/Disk Zones/SIR Generation}
 \usage{
-random_mic(size = NULL, mo = NULL, ab = NULL, ...)
+random_mic(size = NULL, mo = NULL, ab = NULL, skew = "right",
+  severity = 1, ...)
 
-random_disk(size = NULL, mo = NULL, ab = NULL, ...)
+random_disk(size = NULL, mo = NULL, ab = NULL, skew = "left",
+  severity = 1, ...)
 
 random_sir(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...)
 }
 \arguments{
 \item{size}{Desired size of the returned vector. If used in a \link{data.frame} call or \code{dplyr} verb, will get the current (group) size if left blank.}
 
-\item{mo}{Any \link{character} that can be coerced to a valid microorganism code with \code{\link[=as.mo]{as.mo()}}.}
+\item{mo}{Any \link{character} that can be coerced to a valid microorganism code with \code{\link[=as.mo]{as.mo()}}. Can be the same length as \code{size}.}
 
 \item{ab}{Any \link{character} that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}.}
 
+\item{skew}{Direction of skew for MIC or disk values, either \code{"right"} or \code{"left"}. A left-skewed distribution has the majority of the data on the right.}
+
+\item{severity}{Skew severity; higher values will increase the skewedness. Default is \code{2}; use \code{0} to prevent skewedness.}
+
 \item{...}{Ignored, only in place to allow future extensions.}
 
 \item{prob_SIR}{A vector of length 3: the probabilities for "S" (1st value), "I" (2nd value) and "R" (3rd value).}
@@ -31,17 +37,25 @@ class \code{mic} for \code{\link[=random_mic]{random_mic()}} (see \code{\link[=a
 These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial drug, the generated results will reflect reality as much as possible.
 }
 \details{
-The base \R function \code{\link[=sample]{sample()}} is used for generating values.
+Internally, MIC and disk zone values are sampled based on clinical breakpoints defined in the \link{clinical_breakpoints} data set. To create specific generated values per bug or drug, set the \code{mo} and/or \code{ab} argument. The MICs are sampled on a log2 scale and disks linearly, using weighted probabilities. The weights are based on the \code{skew} and \code{severity} arguments:
-
+\itemize{
-Generated values are based on the EUCAST 2025 guideline as implemented in the \link{clinical_breakpoints} data set. To create specific generated values per bug or drug, set the \code{mo} and/or \code{ab} argument.
+\item \code{skew = "right"} places more emphasis on lower MIC or higher disk values.
+\item \code{skew = "left"} places more emphasis on higher MIC or lower disk values.
+\item \code{severity} controls the exponential bias applied.
+}
 }
 \examples{
 random_mic(25)
 random_disk(25)
 random_sir(25)
 
+# add more skewedness, make more realistic by setting a bug and/or drug:
+disks <- random_disk(100, severity = 2, mo = "Escherichia coli", ab = "CIP")
+plot(disks)
+# `plot()` and `ggplot2::autoplot()` allow for coloured bars if `mo` and `ab` are set
+plot(disks, mo = "Escherichia coli", ab = "CIP", guideline = "CLSI 2025")
+
 \donttest{
-# make the random generation more realistic by setting a bug and/or drug:
 random_mic(25, "Klebsiella pneumoniae") # range 0.0625-64
 random_mic(25, "Klebsiella pneumoniae", "meropenem") # range 0.0625-16
 random_mic(25, "Streptococcus pneumoniae", "meropenem") # range 0.0625-4

pkgdown/extra.css

@@ -41,7 +41,7 @@
 
   --bs-success: var(--amr-green-dark) !important;
   --bs-light: var(--amr-green-light) !important;
-  /* --bs-light was this: #128f76a6; that's success with 60% alpha */
+  /* --bs-light was this: #128f76a6; that's bs-success with 60% alpha */
   --bs-info: var(--amr-green-middle) !important;
   --bs-link-color: var(--amr-green-dark) !important;
   --bs-link-color-rgb: var(--amr-green-dark-rgb) !important;
@@ -104,6 +104,16 @@ body.amr-for-python * {
 .navbar .algolia-autocomplete .aa-dropdown-menu {
   background-color: var(--amr-green-dark) !important;
 }
+
+.version-main {
+  font-weight: bold;
+  color: var(--bs-navbar-brand-color);
+}
+.version-build {
+  font-weight: normal;
+  opacity: 0.75;
+  font-size: 0.85em;
+}
 input[type="search"] {
   color: var(--bs-tertiary-bg) !important;
   background-color: var(--amr-green-light) !important;
@@ -149,6 +159,7 @@ this shows on top of every sidebar to the right
   margin-top: 10px;
   border: 2px dashed var(--amr-green-dark);
   text-align: center;
+  background: var(--bs-body-bg);
 }
 .amr-gpt-assistant * {
   width: 90%;

pkgdown/extra.js

@@ -29,10 +29,22 @@
 # ==================================================================== #
 */
 
-$(document).ready(function() {
+$(function () {
   // add GPT assistant info
   $('aside').prepend('<div class="amr-gpt-assistant"><a target="_blank" href="https://chat.amr-for-r.org"><img src="https://amr-for-r.org/AMRforRGPT.svg"></a></div>');
 
+  // split version number in navbar into main version and build number
+  $('.nav-text').each(function () {
+    const $el = $(this);
+    const text = $.trim($el.text());
+    const lastDotIndex = text.lastIndexOf('.');
+    if (lastDotIndex > -1) {
+      const main = text.substring(0, lastDotIndex);
+      const build = text.substring(lastDotIndex);
+      $el.html(`<span class="version-main">${main}</span><span class="version-build">${build}</span>`);
+    }
+  });
+
   // replace 'Developers' with 'Maintainers' on the main page, and "Contributors" on the Authors page
   $(".developers h2").text("Maintainers");
   $(".template-citation-authors h1:nth(0)").text("Contributors and Citation");

tests/testthat/test-zzz.R

@@ -63,10 +63,12 @@ test_that("test-zzz.R", {
     "progress_bar" = "progress",
     "read_html" = "xml2",
     "right_join" = "dplyr",
+    "select" = "dplyr",
     "semi_join" = "dplyr",
     "showQuestion" = "rstudioapi",
     "symbol" = "cli",
     "tibble" = "tibble",
+    "where" = "tidyselect",
     "write.xlsx" = "openxlsx"
   )
 
@@ -127,6 +129,24 @@ test_that("test-zzz.R", {
     "type_sum" = "pillar",
     # readxl
     "read_excel" = "readxl",
+    # recipes
+    "add_step" = "recipes",
+    "bake" = "recipes",
+    "check_new_data" = "recipes",
+    "check_type" = "recipes",
+    "has_role" = "recipes",
+    "is_trained" = "recipes",
+    "prep" = "recipes",
+    "print_step" = "recipes",
+    "rand_id" = "recipes",
+    "recipe" = "recipes",
+    "recipes_eval_select" = "recipes",
+    "sel2char" = "recipes",
+    "step" = "recipes",
+    "step_center" = "recipes",
+    "tidy" = "recipes",
+    # rlang
+    "enquos" = "rlang",
     # rmarkdown
     "html_vignette" = "rmarkdown",
     # skimr

vignettes/AMR_with_tidymodels.Rmd

@@ -28,6 +28,13 @@ Antimicrobial resistance (AMR) is a global health crisis, and understanding resi
 
 In this post, we will explore how to use the `tidymodels` framework to predict resistance patterns in the `example_isolates` dataset in two examples.
 
+This post contains the following examples:
+
+1. Using Antimicrobial Selectors
+2. Predicting ESBL Presence Using Raw MICs
+3. Predicting AMR Over Time
+
+
 ## Example 1: Using Antimicrobial Selectors
 
 By leveraging the power of `tidymodels` and the `AMR` package, we’ll build a reproducible machine learning workflow to predict the Gramstain of the microorganism to two important antibiotic classes: aminoglycosides and beta-lactams.
@@ -208,10 +215,150 @@ This workflow is extensible to other antimicrobial classes and resistance patter
 
 ---
 
+## Example 2: Predicting ESBL Presence Using Raw MICs
 
-## Example 2: Predicting AMR Over Time
+In this second example, we demonstrate how to use `<mic>` columns directly in `tidymodels` workflows using AMR-specific recipe steps. This includes a transformation to `log2` scale using `step_mic_log2()`, which prepares MIC values for use in classification models.
 
-In this second example, we aim to predict antimicrobial resistance (AMR) trends over time using `tidymodels`. We will model resistance to three antibiotics (amoxicillin `AMX`, amoxicillin-clavulanic acid `AMC`, and ciprofloxacin `CIP`), based on historical data grouped by year and hospital ward.
+This approach and idea formed the basis for the publication [DOI: 10.3389/fmicb.2025.1582703](https://doi.org/10.3389/fmicb.2025.1582703) to model the presence of extended-spectrum beta-lactamases (ESBL).
+
+### **Objective**
+
+Our goal is to:
+
+1. Use raw MIC values to predict whether a bacterial isolate produces ESBL.
+2. Apply AMR-aware preprocessing in a `tidymodels` recipe.
+3. Train a classification model and evaluate its predictive performance.
+
+### **Data Preparation**
+
+We use the `esbl_isolates` dataset that comes with the AMR package.
+
+```{r}
+# Load required libraries
+library(AMR)
+library(tidymodels)
+
+# View the esbl_isolates data set
+esbl_isolates
+
+# Prepare a binary outcome and convert to ordered factor
+data <- esbl_isolates %>%
+  mutate(esbl = factor(esbl, levels = c(FALSE, TRUE), ordered = TRUE))
+```
+
+**Explanation:**
+
+- `esbl_isolates`: Contains MIC test results and ESBL status for each isolate.
+- `mutate(esbl = ...)`: Converts the target column to an ordered factor for classification.
+
+### **Defining the Workflow**
+
+#### 1. Preprocessing with a Recipe
+
+We use our `step_mic_log2()` function to log2-transform MIC values, ensuring that MICs are numeric and properly scaled. All MIC predictors can easily and agnostically selected using the new `all_mic_predictors()`:
+
+```{r}
+# Split into training and testing sets
+set.seed(123)
+split <- initial_split(data)
+training_data <- training(split)
+testing_data <- testing(split)
+
+# Define the recipe
+mic_recipe <- recipe(esbl ~ ., data = training_data) %>%
+  remove_role(genus, old_role = "predictor") %>%  # Remove non-informative variable
+  step_mic_log2(all_mic_predictors()) #%>%         # Log2 transform all MIC predictors
+ # prep()
+
+mic_recipe
+```
+
+**Explanation:**
+
+- `remove_role()`: Removes irrelevant variables like genus.
+- `step_mic_log2()`: Applies `log2(as.numeric(...))` to all MIC predictors in one go.
+- `prep()`: Finalises the recipe based on training data.
+
+#### 2. Specifying the Model
+
+We use a simple logistic regression to model ESBL presence, though recent models such as xgboost ([link to `parsnip` manual](https://parsnip.tidymodels.org/reference/details_boost_tree_xgboost.html)) could be much more precise.
+
+```{r}
+# Define the model
+model <- logistic_reg(mode = "classification") %>%
+  set_engine("glm")
+
+model
+```
+
+**Explanation:**
+
+- `logistic_reg()`: Specifies a binary classification model.
+- `set_engine("glm")`: Uses the base R GLM engine.
+
+#### 3. Building the Workflow
+
+```{r}
+# Create workflow
+workflow_model <- workflow() %>%
+  add_recipe(mic_recipe) %>%
+  add_model(model)
+
+workflow_model
+```
+
+### **Training and Evaluating the Model**
+
+```{r}
+# Fit the model
+fitted <- fit(workflow_model, training_data)
+
+# Generate predictions
+predictions <- predict(fitted, testing_data) %>%
+  bind_cols(testing_data)
+
+# Evaluate model performance
+our_metrics <- metric_set(accuracy, kap, ppv, npv)
+metrics <- our_metrics(predictions, truth = esbl, estimate = .pred_class)
+
+metrics
+```
+
+**Explanation:**
+
+- `fit()`: Trains the model on the processed training data.
+- `predict()`: Produces predictions for unseen test data.
+- `metric_set()`: Allows evaluating multiple classification metrics.
+
+It appears we can predict ESBL gene presence with a positive predictive value (PPV) of `r round(metrics$.estimate[3], 3) * 100`% and a negative predictive value (NPV) of `r round(metrics$.estimate[4], 3) * 100` using a simplistic logistic regression model.
+
+### **Visualising Predictions**
+
+We can visualise predictions by comparing predicted and actual ESBL status.
+
+```{r}
+library(ggplot2)
+
+ggplot(predictions, aes(x = esbl, fill = .pred_class)) +
+  geom_bar(position = "stack") +
+  labs(title = "Predicted vs Actual ESBL Status",
+       x = "Actual ESBL",
+       y = "Count") +
+  theme_minimal()
+```
+
+### **Conclusion**
+
+In this example, we showcased how the new `AMR`-specific recipe steps simplify working with `<mic>` columns in `tidymodels`. The `step_mic_log2()` transformation converts ordered MICs to log2-transformed numerics, improving compatibility with classification models.
+
+This pipeline enables realistic, reproducible, and interpretable modelling of antimicrobial resistance data.
+
+---
+
+
+## Example 3: Predicting AMR Over Time
+
+In this third example, we aim to predict antimicrobial resistance (AMR) trends over time using `tidymodels`. We will model resistance to three antibiotics (amoxicillin `AMX`, amoxicillin-clavulanic acid `AMC`, and ciprofloxacin `CIP`), based on historical data grouped by year and hospital ward.
 
 ### **Objective**
 

vignettes/welcome_to_AMR.Rmd

@@ -28,7 +28,7 @@ Note: to keep the package size as small as possible, we only include this vignet
 
 The `AMR` package is a peer-reviewed, [free and open-source](https://amr-for-r.org/#copyright) R package with [zero dependencies](https://en.wikipedia.org/wiki/Dependency_hell) to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial data and properties, by using evidence-based methods. **Our aim is to provide a standard** for clean and reproducible AMR data analysis, that can therefore empower epidemiological analyses to continuously enable surveillance and treatment evaluation in any setting. We are a team of [many different researchers](https://amr-for-r.org/authors.html) from around the globe to make this a successful and durable project!
 
-This work was published in the Journal of Statistical Software (Volume 104(3); \doi{10.18637/jss.v104.i03}) and formed the basis of two PhD theses (\doi{10.33612/diss.177417131} and \doi{10.33612/diss.192486375}).
+This work was published in the Journal of Statistical Software (Volume 104(3); [DOI 10.18637/jss.v104.i03](https://doi.org/10.18637/jss.v104.i03)) and formed the basis of two PhD theses ([DOI 10.33612/diss.177417131](https://doi.org/10.33612/diss.177417131) and [DOI 10.33612/diss.192486375](https://doi.org/10.33612/diss.192486375)).
 
 After installing this package, R knows [**`r AMR:::format_included_data_number(AMR::microorganisms)` distinct microbial species**](https://amr-for-r.org/reference/microorganisms.html) (updated June 2024) and all [**`r AMR:::format_included_data_number(NROW(AMR::antimicrobials) + NROW(AMR::antivirals))` antimicrobial and antiviral drugs**](https://amr-for-r.org/reference/antimicrobials.html) by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral clinical breakpoint guidelines from CLSI `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, grepl("CLSI", guideline))$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, grepl("CLSI", guideline))$guideline)))` and EUCAST `r min(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, grepl("EUCAST", guideline))$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(AMR::clinical_breakpoints, grepl("EUCAST", guideline))$guideline)))` are included, even with epidemiological cut-off (ECOFF) values. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). **It was designed to work in any setting, including those with very limited resources**. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl) and the [University Medical Center Groningen](https://www.umcg.nl).