update sir to include interpretation details

.github/prehooks/pre-commit

@@ -68,49 +68,56 @@ echo ""
 # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 echo "Updating semantic versioning and date..."
 
-# Get tags from remote and remove tags not on remote
+current_branch=$(git rev-parse --abbrev-ref HEAD)
-git fetch origin --prune --prune-tags --quiet
+if [ "$current_branch" != "main" ]; then
-currenttagfull=$(git describe --tags --abbrev=0)
+  echo "- Current branch is '$current_branch'; skipping version/date update (only runs on 'main')"
-currenttag=$(git describe --tags --abbrev=0 | sed 's/v//')
-
-# Assume main branch to be 'main' or 'master'
-defaultbranch=$(git branch | cut -c 3- | grep -E '^master$|^main$')
-if [ "$currenttag" = "" ]; then
-  currenttag="0.0.1"
-  currentcommit=$(git rev-list --count ${defaultbranch})
-  echo "- No git tags found, creating one in format 'v(x).(y).(z)' - currently ${currentcommit} previous commits in '${defaultbranch}'"
 else
-  currentcommit=$(git rev-list --count ${currenttagfull}..${defaultbranch})
+  # Version update logic begins here
-  echo "- Latest tag is '${currenttagfull}', with ${currentcommit} previous commits in '${defaultbranch}'"
+  
-fi
+  # Get tags from remote and remove tags not on remote
-
+  git fetch origin --prune --prune-tags --quiet
-# Combine tag and commit number
+  currenttagfull=$(git describe --tags --abbrev=0)
-currentversion="$currenttag.$((currentcommit + 9001))"
+  currenttag=$(git describe --tags --abbrev=0 | sed 's/v//')
-echo "- ${currentpkg} pkg version set to ${currentversion}"
+  
-
+  # Assume main branch to be 'main' or 'master'
-# Update version number and date in DESCRIPTION
+  defaultbranch=$(git branch | cut -c 3- | grep -E '^master$|^main$')
-sed -i -- "s/^Version: .*/Version: ${currentversion}/" DESCRIPTION
+  if [ "$currenttag" = "" ]; then
-sed -i -- "s/^Date: .*/Date: $(date '+%Y-%m-%d')/" DESCRIPTION
+    currenttag="0.0.1"
-echo "- Updated version number and date in ./DESCRIPTION"
+    currentcommit=$(git rev-list --count ${defaultbranch})
-rm -f DESCRIPTION--
+    echo "- No git tags found, creating one in format 'v(x).(y).(z)' - currently ${currentcommit} previous commits in '${defaultbranch}'"
-git add DESCRIPTION
+  else
-
+    currentcommit=$(git rev-list --count ${currenttagfull}..${defaultbranch})
-# Update version number in NEWS.md
+    echo "- Latest tag is '${currenttagfull}', with ${currentcommit} previous commits in '${defaultbranch}'"
-if [ -e "NEWS.md" ]; then
-  if [ "$currentpkg" = "your" ]; then
-    currentpkg=""
   fi
-  sed -i -- "1s/.*/# ${currentpkg} ${currentversion}/" NEWS.md
+  
-  echo "- Updated version number in ./NEWS.md"
+  # Combine tag and commit number
-  rm -f NEWS.md--
+  currentversion="$currenttag.$((currentcommit + 9001))"
-  git add NEWS.md
+  echo "- ${currentpkg} pkg version set to ${currentversion}"
-else
+  
-  echo "- No NEWS.md found!"
+  # Update version number and date in DESCRIPTION
+  sed -i -- "s/^Version: .*/Version: ${currentversion}/" DESCRIPTION
+  sed -i -- "s/^Date: .*/Date: $(date '+%Y-%m-%d')/" DESCRIPTION
+  echo "- Updated version number and date in ./DESCRIPTION"
+  rm -f DESCRIPTION--
+  git add DESCRIPTION
+  
+  # Update version number in NEWS.md
+  if [ -e "NEWS.md" ]; then
+    if [ "$currentpkg" = "your" ]; then
+      currentpkg=""
+    fi
+    sed -i -- "1s/.*/# ${currentpkg} ${currentversion}/" NEWS.md
+    echo "- Updated version number in ./NEWS.md"
+    rm -f NEWS.md--
+    git add NEWS.md
+  else
+    echo "- No NEWS.md found!"
+  fi
+  echo ""
+  
+  # Save the version number for use in the commit-msg hook
+  echo "${currentversion}" > .git/commit_version.tmp
 fi
-echo ""
-
-# Save the version number for use in the commit-msg hook
-echo "${currentversion}" > .git/commit_version.tmp
 
 git add data-raw/*
 git add data/*

.github/workflows/check-old-tinytest.yaml

@@ -59,8 +59,15 @@ jobs:
 
     env:
       R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
+      LANG: en_US.UTF-8
+      LC_ALL: en_US.UTF-8
 
     steps:
+      - name: Set up locales
+        run: |
+          sudo locale-gen en_US.UTF-8
+          sudo update-locale LANG=en_US.UTF-8
+
       - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: AMR
-Version: 3.0.0.9008
+Version: 3.0.0.9017
-Date: 2025-07-17
+Date: 2025-07-28
 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

NAMESPACE

@@ -12,6 +12,7 @@ S3method("[",deprecated_amr_dataset)
 S3method("[",disk)
 S3method("[",mic)
 S3method("[",mo)
+S3method("[",sir)
 S3method("[<-",ab)
 S3method("[<-",av)
 S3method("[<-",disk)
@@ -24,6 +25,7 @@ S3method("[[",deprecated_amr_dataset)
 S3method("[[",disk)
 S3method("[[",mic)
 S3method("[[",mo)
+S3method("[[",sir)
 S3method("[[<-",ab)
 S3method("[[<-",av)
 S3method("[[<-",disk)
@@ -99,6 +101,7 @@ S3method(print,custom_eucast_rules)
 S3method(print,custom_mdro_guideline)
 S3method(print,deprecated_amr_dataset)
 S3method(print,disk)
+S3method(print,interpreted_sir)
 S3method(print,mic)
 S3method(print,mo)
 S3method(print,mo_renamed)

NEWS.md

@@ -1,4 +1,4 @@
-# AMR 3.0.0.9008
+# AMR 3.0.0.9017
 
 This is primarily a bugfix release, though we added one nice feature too.
 
@@ -13,9 +13,12 @@ This is primarily a bugfix release, though we added one nice feature too.
 * 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 `as.sir()` to pick right breakpoint when `uti = FALSE` (#216)
 * 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 all plotting to contain a separate colour for SDD (susceptible dose-dependent) (#223)
 * Fixed some specific Dutch translations for antimicrobials
+* Added `names` to `age_groups()` so that custom names can be given (#215)
+* Added note to `as.sir()` to make it explicit when higher-level taxonomic breakpoints are used (#218)
 * Updated `random_mic()` and `random_disk()` to set skewedness of the distribution and allow multiple microorganisms
 
 

R/aa_helper_functions.R

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

R/age.R

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

R/ggplot_sir.R

@@ -177,8 +177,8 @@ ggplot_sir <- function(data,
                        nrow = NULL,
                        colours = c(
                          S = "#3CAEA3",
-                         SI = "#3CAEA3",
                          SDD = "#8FD6C4",
+                         SI = "#3CAEA3",
                          I = "#F6D55C",
                          IR = "#ED553B",
                          R = "#ED553B"
@@ -206,7 +206,7 @@ ggplot_sir <- function(data,
   meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
   language <- validate_language(language)
   meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
-  meet_criteria(colours, allow_class = c("character", "logical"))
+  meet_criteria(colours, allow_class = c("character", "logical"), allow_NULL = TRUE)
   meet_criteria(datalabels, allow_class = "logical", has_length = 1)
   meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
   meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
@@ -246,7 +246,7 @@ ggplot_sir <- function(data,
     ) +
     theme_sir()
 
-  if (fill == "interpretation") {
+  if (fill == "interpretation" && !is.null(colours) && !isFALSE(colours)) {
     p <- suppressWarnings(p + scale_sir_colours(aesthetics = "fill", colours = colours))
   }
 

R/plotting.R

@@ -90,6 +90,10 @@
 #'   autoplot(some_mic_values, mo = "Escherichia coli", ab = "cipro")
 #' }
 #' if (require("ggplot2")) {
+#'   autoplot(some_mic_values, mo = "Staph aureus", ab = "Ceftaroline", guideline = "CLSI")
+#' }
+#'
+#' if (require("ggplot2")) {
 #'   # support for 27 languages, various guidelines, and many options
 #'   autoplot(some_disk_values,
 #'     mo = "Escherichia coli", ab = "cipro",
@@ -146,7 +150,7 @@
 #'     aes(group, mic)
 #'   ) +
 #'     geom_boxplot() +
-#'     geom_violin(linetype = 2, colour = "grey", fill = NA) +
+#'     geom_violin(linetype = 2, colour = "grey30", fill = NA) +
 #'     scale_y_mic()
 #' }
 #' if (require("ggplot2")) {
@@ -158,7 +162,7 @@
 #'     aes(group, mic)
 #'   ) +
 #'     geom_boxplot() +
-#'     geom_violin(linetype = 2, colour = "grey", fill = NA) +
+#'     geom_violin(linetype = 2, colour = "grey30", fill = NA) +
 #'     scale_y_mic(mic_range = c(NA, 0.25))
 #' }
 #'
@@ -191,7 +195,7 @@
 #'     aes(x = group, y = mic, colour = sir)
 #'   ) +
 #'     theme_minimal() +
-#'     geom_boxplot(fill = NA, colour = "grey") +
+#'     geom_boxplot(fill = NA, colour = "grey30") +
 #'     geom_jitter(width = 0.25)
 #'
 #'   plain
@@ -377,12 +381,7 @@ 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 <- expand_SIR_colours(colours_SIR, unname = FALSE)
-    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
@@ -392,24 +391,19 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
       args,
       list(
         aesthetics = aesthetics,
-        values = c(
+        values = c(colours_SIR, NI = "grey30")
-          S = colours_SIR[1],
-          SDD = colours_SIR[2],
-          I = colours_SIR[3],
-          R = colours_SIR[4],
-          NI = "grey30"
-        )
       )
     )
   }
   scale <- do.call(ggplot_fn, args)
 
   scale$labels <- function(x) {
-    stop_ifnot(all(x %in% c(levels(NA_sir_), NA)),
+    stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)),
       "Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
       call = FALSE
     )
-    x <- as.character(as.sir(x))
+    x <- as.character(x)
+    x[!x %in% c("SI", "IR")] <- as.character(as.sir(x[!x %in% c("SI", "IR")]))
     if (!is.null(language)) {
       x[x == "S"] <- "(S) Susceptible"
       x[x == "SDD"] <- "(SDD) Susceptible dose-dependent"
@@ -419,6 +413,8 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
         x[x == "I"] <- "(I) Intermediate"
       }
       x[x == "R"] <- "(R) Resistant"
+      x[x == "SI"] <- "(S/I) Susceptible"
+      x[x == "IR"] <- "(I/R) Non-susceptible"
       x[x == "NI"] <- "(NI) Non-interpretable"
       x <- translate_AMR(x, language = language)
     }
@@ -426,7 +422,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
   }
   scale$limits <- function(x, ...) {
     # force SIR in the right order
-    as.character(sort(factor(x, levels = levels(NA_sir_))))
+    as.character(sort(factor(x, levels = c(levels(NA_sir_), "SI", "IR"))))
   }
 
   scale
@@ -536,6 +532,7 @@ plot.mic <- function(x,
 
   x <- as.mic(x) # make sure that currently implemented MIC levels are used
   main <- gsub(" +", " ", paste0(main, collapse = " "))
+  colours_SIR <- expand_SIR_colours(colours_SIR)
 
   x <- plotrange_as_table(x, expand = expand)
   cols_sub <- plot_colours_subtitle_guideline(
@@ -683,6 +680,8 @@ autoplot.mic <- function(object,
     title <- gsub(" +", " ", paste0(title, collapse = " "))
   }
 
+  colours_SIR <- expand_SIR_colours(colours_SIR)
+
   object <- as.mic(object) # make sure that currently implemented MIC levels are used
   x <- plotrange_as_table(object, expand = expand)
   cols_sub <- plot_colours_subtitle_guideline(
@@ -702,12 +701,14 @@ autoplot.mic <- function(object,
   colnames(df) <- c("mic", "count")
   df$cols <- cols_sub$cols
   df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
-  df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
+  df$cols[df$cols == colours_SIR[2]] <- "(SDD) Susceptible dose-dependent"
-  df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
+  df$cols[df$cols == colours_SIR[3]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
+  df$cols[df$cols == colours_SIR[4]] <- "(R) Resistant"
   df$cols <- factor(translate_into_language(df$cols, language = language),
     levels = translate_into_language(
       c(
         "(S) Susceptible",
+        "(SDD) Susceptible dose-dependent",
         paste("(I)", plot_name_of_I(cols_sub$guideline)),
         "(R) Resistant"
       ),
@@ -721,10 +722,10 @@ autoplot.mic <- function(object,
     vals <- c(
       "(S) Susceptible" = colours_SIR[1],
       "(SDD) Susceptible dose-dependent" = colours_SIR[2],
-      "(I) Susceptible, incr. exp." = colours_SIR[2],
+      "(I) Susceptible, incr. exp." = colours_SIR[3],
-      "(I) Intermediate" = colours_SIR[2],
+      "(I) Intermediate" = colours_SIR[3],
-      "(R) Resistant" = colours_SIR[3],
+      "(R) Resistant" = colours_SIR[4],
-      "(NI) Non-interpretable" = "grey"
+      "(NI) Non-interpretable" = "grey30"
     )
     names(vals) <- translate_into_language(names(vals), language = language)
     p <- p +
@@ -790,6 +791,7 @@ plot.disk <- function(x,
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
   main <- gsub(" +", " ", paste0(main, collapse = " "))
+  colours_SIR <- expand_SIR_colours(colours_SIR)
 
   x <- plotrange_as_table(x, expand = expand)
   cols_sub <- plot_colours_subtitle_guideline(
@@ -935,6 +937,8 @@ autoplot.disk <- function(object,
     title <- gsub(" +", " ", paste0(title, collapse = " "))
   }
 
+  colours_SIR <- expand_SIR_colours(colours_SIR)
+
   x <- plotrange_as_table(object, expand = expand)
   cols_sub <- plot_colours_subtitle_guideline(
     x = x,
@@ -952,10 +956,10 @@ autoplot.disk <- function(object,
   df <- as.data.frame(x, stringsAsFactors = TRUE)
   colnames(df) <- c("disk", "count")
   df$cols <- cols_sub$cols
-
   df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
-  df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
+  df$cols[df$cols == colours_SIR[2]] <- "(SDD) Susceptible dose-dependent"
-  df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
+  df$cols[df$cols == colours_SIR[3]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
+  df$cols[df$cols == colours_SIR[4]] <- "(R) Resistant"
   df$cols <- factor(translate_into_language(df$cols, language = language),
     levels = translate_into_language(
       c(
@@ -973,10 +977,10 @@ autoplot.disk <- function(object,
     vals <- c(
       "(S) Susceptible" = colours_SIR[1],
       "(SDD) Susceptible dose-dependent" = colours_SIR[2],
-      "(I) Susceptible, incr. exp." = colours_SIR[2],
+      "(I) Susceptible, incr. exp." = colours_SIR[3],
-      "(I) Intermediate" = colours_SIR[2],
+      "(I) Intermediate" = colours_SIR[3],
-      "(R) Resistant" = colours_SIR[3],
+      "(R) Resistant" = colours_SIR[4],
-      "(NI) Non-interpretable" = "grey"
+      "(NI) Non-interpretable" = "grey30"
     )
     names(vals) <- translate_into_language(names(vals), language = language)
     p <- p +
@@ -1093,12 +1097,7 @@ barplot.sir <- function(height,
   language <- validate_language(language)
   meet_criteria(expand, allow_class = "logical", has_length = 1)
 
-  if (length(colours_SIR) == 1) {
+  colours_SIR <- expand_SIR_colours(colours_SIR)
-    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, "grey30")
@@ -1148,12 +1147,7 @@ autoplot.sir <- function(object,
     title <- gsub(" +", " ", paste0(title, collapse = " "))
   }
 
-  if (length(colours_SIR) == 1) {
+  colours_SIR <- expand_SIR_colours(colours_SIR)
-    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")
@@ -1252,13 +1246,6 @@ 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
@@ -1382,11 +1369,7 @@ scale_sir_colours <- function(...,
     colours_SIR <- list(...)$colours
   }
 
-  if (length(colours_SIR) == 1) {
+  colours_SIR <- expand_SIR_colours(colours_SIR, unname = FALSE)
-    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])
-  }
 
   # behaviour when coming from ggplot_sir()
   if ("colours" %in% names(list(...))) {
@@ -1502,3 +1485,39 @@ labels_sir_count <- function(position = NULL,
     }
   )
 }
+
+expand_SIR_colours <- function(colours_SIR, unname = TRUE) {
+  sir_order <- c("S", "SDD", "I", "R", "SI", "IR")
+
+  if (is.null(names(colours_SIR))) {
+    if (length(colours_SIR) == 1) {
+      colours_SIR <- rep(colours_SIR, 4)
+    } else if (length(colours_SIR) == 3) {
+      # old method for AMR < 3.0.1 which allowed for 3 colours
+      # fill in green for SDD as extra colour
+      colours_SIR <- c(colours_SIR[1], colours_SIR[1], colours_SIR[2], colours_SIR[3])
+    }
+    if (length(colours_SIR) == 4) {
+      # add colours for SI (same as S) and IR (same as R)
+      colours_SIR <- c(colours_SIR[1:4], colours_SIR[1], colours_SIR[4])
+    }
+    names(colours_SIR) <- sir_order
+  } else {
+    # named input: match and reorder
+    stop_ifnot(
+      all(names(colours_SIR) %in% sir_order),
+      "Unknown names in `colours_SIR`. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "."
+    )
+    if (length(colours_SIR) == 4) {
+      # add colours for SI (same as S) and IR (same as R)
+      colours_SIR <- c(colours_SIR[1:4], SI = unname(colours_SIR[1]), IR = unname(colours_SIR[4]))
+    }
+    colours_SIR <- colours_SIR[sir_order]
+  }
+
+  if (unname) {
+    colours_SIR <- unname(colours_SIR)
+  }
+
+  return(colours_SIR)
+}

R/sir.R

@@ -385,26 +385,15 @@ as.sir <- function(x, ...) {
   UseMethod("as.sir")
 }
 
-as_sir_structure <- function(x,
+as_sir_structure <- function(x) {
-                             guideline = NULL,
+  int <- attr(x, "interpretation_details")
-                             mo = NULL,
-                             ab = NULL,
-                             method = NULL,
-                             ref_tbl = NULL,
-                             ref_breakpoints = NULL) {
   structure(
     factor(as.character(unlist(unname(x))),
       levels = c("S", "SDD", "I", "R", "NI"),
       ordered = TRUE
     ),
-    # TODO for #170
+    interpretation_details = int,
-    # guideline = guideline,
+    class = c(if (!is.null(int)) "interpreted_sir" else NULL, "sir", "ordered", "factor")
-    # mo = mo,
-    # ab = ab,
-    # method = method,
-    # ref_tbl = ref_tbl,
-    # ref_breakpoints = ref_breakpoints,
-    class = c("sir", "ordered", "factor")
   )
 }
 
@@ -1140,7 +1129,6 @@ as_sir_method <- function(method_short,
   current_sir_interpretation_history <- NROW(AMR_env$sir_interpretation_history)
 
   if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
-    message()
     message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n", add_fn = font_green)
   }
 
@@ -1558,7 +1546,7 @@ as_sir_method <- function(method_short,
       ))
 
     if (breakpoint_type == "animal") {
-      # 2025-03-13 for now, only strictly follow guideline for current host, no extrapolation
+      # 2025-03-13/ for now, only strictly follow guideline for current host, no extrapolation
       breakpoints_current <- breakpoints_current[which(breakpoints_current$host == host_current), , drop = FALSE]
     }
 
@@ -1650,32 +1638,31 @@ as_sir_method <- function(method_short,
         breakpoint_S_R = vectorise_log_entry(NA_character_, length(rows)),
         stringsAsFactors = FALSE
       )
+      attr(new_sir, "interpretation_details") <- out
       out <- subset(out, !is.na(input_given))
       AMR_env$sir_interpretation_history <- rbind_AMR(AMR_env$sir_interpretation_history, out)
       notes <- c(notes, notes_current)
+      df[rows, "result"] <- new_sir
       next
     }
 
-    # sort on host and taxonomic rank
+    # if the user explicitly set uti, keep only those rows
-    # (this will e.g. prefer 'species' breakpoints over 'order' breakpoints)
+    if (!is.na(uti_current)) {
-    if (is.na(uti_current)) {
+      breakpoints_current <- breakpoints_current[breakpoints_current$uti == uti_current, , drop = FALSE]
-      breakpoints_current <- breakpoints_current %pm>%
-        #  `uti` is a column in the data set
-        # this will put UTI = FALSE first, then UTI = NA, then UTI = TRUE
-        pm_mutate(uti_index = ifelse(!is.na(uti) & uti == FALSE, 1,
-          ifelse(is.na(uti), 2,
-            3
-          )
-        )) %pm>%
-        # be as specific as possible (i.e. prefer species over genus):
-        pm_arrange(rank_index, uti_index)
-    } else if (uti_current == TRUE) {
-      breakpoints_current <- breakpoints_current %pm>%
-        subset(uti == TRUE) %pm>%
-        # be as specific as possible (i.e. prefer species over genus):
-        pm_arrange(rank_index)
     }
 
+    # build a helper factor so FALSE < NA < TRUE
+    uti_index <- factor(
+      ifelse(is.na(breakpoints_current$uti), "NA",
+        as.character(breakpoints_current$uti)
+      ),
+      levels = c("FALSE", "NA", "TRUE")
+    )
+
+    # sort on host and taxonomic rank first, then by UTI
+    # (this will e.g. prefer 'species' breakpoints over 'order' breakpoints)
+    breakpoints_current <- breakpoints_current[order(breakpoints_current$rank_index, uti_index), , drop = FALSE]
+
     # throw messages for different body sites
     site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
     if (is.na(site)) {
@@ -1687,7 +1674,7 @@ as_sir_method <- function(method_short,
       # only UTI breakpoints available
       notes_current <- paste0(
         notes_current, "\n",
-        paste0("Breakpoints for ", font_bold(ab_formatted), " in ", mo_formatted, " are only available for (uncomplicated) urinary tract infections (UTI); assuming `uti = TRUE`.")
+        paste0("Breakpoints for ", font_bold(ab_formatted), " in ", mo_formatted, " are only available for (uncomplicated) urinary tract infections (UTI) - assuming `uti = TRUE`.")
       )
     } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti_current)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteUTI", mo_current, ab_current)) {
       # both UTI and Non-UTI breakpoints available
@@ -1710,7 +1697,7 @@ as_sir_method <- function(method_short,
       new_sir <- rep(as.sir("R"), length(rows))
       notes_current <- paste0(
         notes_current, "\n",
-        paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, "")
+        paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ".")
       )
     } else if (nrow(breakpoints_current) == 0) {
       # no rules available
@@ -1718,41 +1705,48 @@ as_sir_method <- function(method_short,
     } else {
       # then run the rules
       breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
+      if (breakpoints_current$rank_index > 3) {
+        # we resort to a high-level taxonomic record since there are no breakpoint on genus (rank_index = 3) or lower, so note this
+        notes_current <- paste0(
+          "No genus- or species-level breakpoint available - applying higher taxonomic level instead.\n",
+          notes_current
+        )
+      }
 
       notes_current <- paste0(
         notes_current, "\n",
         ifelse(breakpoints_current$mo == "UNKNOWN" | breakpoints_current$ref_tbl %like% "PK.*PD",
-          "Some PK/PD breakpoints were applied - use `include_PKPD = FALSE` to prevent this",
+          "Some PK/PD breakpoints were applied - use `include_PKPD = FALSE` to prevent this.",
           ""
         ),
         "\n",
         ifelse(breakpoints_current$site %like% "screen" | breakpoints_current$ref_tbl %like% "screen",
-          "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this",
+          "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this.",
           ""
         ),
         "\n",
         ifelse(method == "mic" & capped_mic_handling %in% c("conservative", "inverse") & as.character(values_bak) %like% "^[<][0-9]",
-          paste0("MIC values with the operator '<' are all considered 'S' since capped_mic_handling = \"", capped_mic_handling, "\""),
+          paste0("MIC values with the operator '<' are all considered 'S' since capped_mic_handling = \"", capped_mic_handling, "\"."),
           ""
         ),
         "\n",
         ifelse(method == "mic" & capped_mic_handling %in% c("conservative", "inverse") & as.character(values_bak) %like% "^[>][0-9]",
-          paste0("MIC values with the operator '>' are all considered 'R' since capped_mic_handling = \"", capped_mic_handling, "\""),
+          paste0("MIC values with the operator '>' are all considered 'R' since capped_mic_handling = \"", capped_mic_handling, "\"."),
           ""
         ),
         "\n",
         ifelse(method == "mic" & capped_mic_handling %in% c("conservative", "standard") & as.character(values_bak) %like% "^[><]=[0-9]" & as.double(values) > breakpoints_current$breakpoint_S & as.double(values) < breakpoints_current$breakpoint_R,
-          paste0("MIC values within the breakpoint guideline range with the operator '<=' or '>=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\""),
+          paste0("MIC values within the breakpoint guideline range with the operator '<=' or '>=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\"."),
           ""
         ),
         "\n",
         ifelse(method == "mic" & capped_mic_handling %in% c("conservative", "standard") & as.character(values_bak) %like% "^<=[0-9]" & as.double(values) == breakpoints_current$breakpoint_R,
-          paste0("MIC values at the R breakpoint with the operator '<=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\""),
+          paste0("MIC values at the R breakpoint with the operator '<=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\"."),
           ""
         ),
         "\n",
         ifelse(method == "mic" & capped_mic_handling %in% c("conservative", "standard") & as.character(values_bak) %like% "^>=[0-9]" & as.double(values) == breakpoints_current$breakpoint_S,
-          paste0("MIC values at the S breakpoint with the operator '>=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\""),
+          paste0("MIC values at the S breakpoint with the operator '>=' are considered 'NI' (non-interpretable) since capped_mic_handling = \"", capped_mic_handling, "\"."),
           ""
         )
       )
@@ -1762,7 +1756,7 @@ as_sir_method <- function(method_short,
         notes_current <- paste0(
           notes_current, "\n",
           ifelse(!is.na(breakpoints_current$breakpoint_S) & is.na(breakpoints_current$breakpoint_R),
-            "NAs because of missing R breakpoints were substituted with R since substitute_missing_r_breakpoint = TRUE",
+            "NAs because of missing R breakpoints were substituted with R since substitute_missing_r_breakpoint = TRUE.",
             ""
           )
         )
@@ -1801,7 +1795,7 @@ as_sir_method <- function(method_short,
       }
 
       # write to verbose output
-      notes_current <- trimws2(notes_current)
+      notes_current <- gsub("\n\n", "\n", trimws2(notes_current), fixed = TRUE)
       notes_current[notes_current == ""] <- NA_character_
       out <- data.frame(
         # recycling 1 to 2 rows does not always seem to work, which is why vectorise_log_entry() was added
@@ -1824,6 +1818,7 @@ as_sir_method <- function(method_short,
         breakpoint_S_R = vectorise_log_entry(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)),
         stringsAsFactors = FALSE
       )
+      attr(new_sir, "interpretation_details") <- out
       out <- subset(out, !is.na(input_given))
       AMR_env$sir_interpretation_history <- rbind_AMR(AMR_env$sir_interpretation_history, out)
     }
@@ -1868,20 +1863,33 @@ as_sir_method <- function(method_short,
   new_part <- new_part[order(new_part$index), , drop = FALSE]
   AMR_env$sir_interpretation_history <- rbind_AMR(old_part, new_part)
 
-  df$result
+  as_sir_structure(df$result)
 }
 
 #' @rdname as.sir
+#' @param sir_values SIR values that were interpreted from MIC or disk diffusion values using [as.sir()].
 #' @param clean A [logical] to indicate whether previously stored results should be forgotten after returning the 'logbook' with results.
 #' @export
-sir_interpretation_history <- function(clean = FALSE) {
+sir_interpretation_history <- function(sir_values = NULL, clean = FALSE) {
+  # for AMR v3.0.0 and lower, the first argument was `clean`, so allow `sir_interpretation_history(TRUE)` to keep working
+  if (is.logical(sir_values) && missing(clean)) {
+    clean <- sir_values
+    sir_values <- NULL
+    warning_("For `sir_interpretation_history()`, the `clean` argument is no longer the first argument, please update your code to explicitly state 'clean': `sir_interpretation_history(clean = ", clean, ")`.")
+  }
+  meet_criteria(sir_values, allow_class = "sir", allow_NULL = TRUE)
   meet_criteria(clean, allow_class = "logical", has_length = 1)
-  out <- AMR_env$sir_interpretation_history
+
-  out <- out[which(!is.na(out$datetime)), , drop = FALSE]
+  if (!is.null(sir_values)) {
-  out$outcome <- as.sir(out$outcome)
+    out <- attr(sir_values, "interpretation_details")
-  out$site <- as.character(out$site)
+  } else {
-  if (isTRUE(clean)) {
+    out <- AMR_env$sir_interpretation_history
-    AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
+    out <- out[which(!is.na(out$datetime)), , drop = FALSE]
+    out$outcome <- as.sir(out$outcome)
+    out$site <- as.character(out$site)
+    if (isTRUE(clean)) {
+      AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
+    }
   }
   if (pkg_is_available("tibble")) {
     out <- import_fn("as_tibble", "tibble")(out)
@@ -2005,21 +2013,60 @@ get_skimmers.sir <- function(column) {
 #' @export
 #' @noRd
 print.sir <- function(x, ...) {
-  x_name <- deparse(substitute(x))
   cat("Class 'sir'\n")
-  # TODO for #170
-  # if (!is.null(attributes(x)$guideline) && !all(is.na(attributes(x)$guideline))) {
-  #   cat(font_blue(word_wrap("These values were interpreted using ",
-  #                           font_bold(vector_and(attributes(x)$guideline, quotes = FALSE)),
-  #                           " based on ",
-  #                           vector_and(attributes(x)$method, quotes = FALSE),
-  #                           " values. ",
-  #                           "Use `sir_interpretation_history(", x_name, ")` to return a full logbook.")))
-  #   cat("\n")
-  # }
   print(as.character(x), quote = FALSE)
 }
 
+#' @method print interpreted_sir
+#' @export
+#' @noRd
+print.interpreted_sir <- function(x, ...) {
+  cat("Class 'sir'\n")
+  print(as.character(x), quote = FALSE)
+
+  if (length(x) == 0) {
+    return(invisible())
+  }
+
+  int <- attr(x, "interpretation_details")
+  if (NROW(int) == 0) {
+    if (length(x) == 1) {
+      cat(font_blue(word_wrap("Source data were lost for this interpreted value.")))
+    } else {
+      cat(font_blue(word_wrap("Source data were lost for these interpreted values.")))
+    }
+  } else {
+    relevant_cols <- int[, c("guideline", "method", "ab", "mo"), drop = FALSE]
+    relevant_cols <- unique(relevant_cols)
+    vals1_plural <- ifelse(length(x) == 1, "This value was", "These values were")
+    vals2_plural <- ifelse(length(x) == 1, "value", "values")
+    method_fn <- ifelse(relevant_cols$method == "MIC", "MIC", "disk diffusion")
+    if (NROW(relevant_cols) == 1) {
+      in_host <- ifelse(relevant_cols$host == "human", "", paste0(" in ", relevant_cols$host))
+      cat(font_blue(word_wrap(
+        vals1_plural, " interpreted using ",
+        relevant_cols$guideline,
+        " based on the ",
+        method_fn,
+        " ", vals2_plural, " for ",
+        ab_name(relevant_cols$ab, language = NULL, info = FALSE, tolower = TRUE), " in ",
+        italicise_taxonomy(mo_name(relevant_cols$mo, language = NULL, info = FALSE), type = "ansi"),
+        in_host,
+        "."
+      )))
+    } else {
+      cat(font_blue(word_wrap(
+        vals1_plural, " interpreted using ",
+        vector_and(relevant_cols$guideline, quotes = FALSE),
+        " based on ",
+        vector_and(method_fn, quotes = FALSE),
+        " ", vals2_plural, "."
+      )))
+    }
+    cat(font_blue(word_wrap("\nUse `sir_interpretation_history()` on this object to return a full logbook.\n")))
+  }
+}
+
 
 #' @method as.double sir
 #' @export
@@ -2075,51 +2122,132 @@ summary.sir <- function(object, ...) {
   value
 }
 
+#' @method [ sir
+#' @export
+#' @noRd
+"[.sir" <- function(x, ...) {
+  y <- NextMethod()
+  det <- attr(x, "interpretation_details")
+  if (!is.null(det)) {
+    subset_idx <- seq_along(x)[...]
+    # safer than relying on implicit eval inside NextMethod()
+    attr(y, "interpretation_details") <- det[subset_idx, , drop = FALSE]
+  }
+  y
+}
+#' @method [[ sir
+#' @export
+#' @noRd
+"[[.sir" <- function(x, i, ...) {
+  if (length(i) != 1L) {
+    stop("attempt to select more than one element with [[.", call. = FALSE)
+  }
+  x[i] # calls `[.sir`, ensures attr alignment
+}
+
 #' @method [<- sir
 #' @export
 #' @noRd
 "[<-.sir" <- function(i, j, ..., value) {
   value <- as.sir(value)
   y <- NextMethod()
-  attributes(y) <- attributes(i)
+
+  old_det <- attr(i, "interpretation_details")
+  new_det <- attr(value, "interpretation_details")
+
+  len_y <- length(y)
+
+  # Neither i nor value have details -> do nothing
+  if (is.null(old_det) && is.null(new_det)) {
+    return(y)
+  }
+
+  # Start building full_det as copy of old_det or empty
+  full_det <- if (!is.null(old_det)) old_det else data.frame(row = seq_along(i))
+
+  # Ensure full_det has correct row count and order
+  if (nrow(full_det) != length(i)) {
+    attr(y, "interpretation_details") <- NULL
+    return(y)
+  }
+
+  # Which rows are being assigned?
+  assign_idx <- if (missing(j)) seq_along(i) else j
+  assign_idx <- as.integer(assign_idx)
+
+  # If new_det is missing or too short, fill it
+  if (is.null(new_det)) {
+    new_det <- data.frame(row = assign_idx)
+  } else if (nrow(new_det) != length(value)) {
+    new_det <- data.frame(row = assign_idx)
+  }
+
+  # Add temporary .row to track positions
+  full_det$.row <- seq_len(nrow(full_det))
+  new_det$.row <- assign_idx
+
+  # Replace old rows with new rows
+  full_det <- rbind(
+    subset(full_det, !.row %in% assign_idx),
+    new_det
+  )
+  full_det <- full_det[order(full_det$.row), , drop = FALSE]
+  full_det$.row <- NULL
+
+  # Clean up: ensure right number of rows
+  if (nrow(full_det) == len_y) {
+    attr(y, "interpretation_details") <- full_det
+  } else {
+    attr(y, "interpretation_details") <- NULL
+  }
+
   y
 }
 #' @method [[<- sir
 #' @export
 #' @noRd
 "[[<-.sir" <- function(i, j, ..., value) {
-  value <- as.sir(value)
+  if (!is.null(det) && length(i) == 1 && nrow(det) >= i) {
-  y <- NextMethod()
+    i[j] <- value
-  attributes(y) <- attributes(i)
+    i
-  y
+  } else {
+    NextMethod()
+  }
 }
 #' @method c sir
 #' @export
 #' @noRd
-c.sir <- function(...) {
+c.sir <- function(..., recursive = FALSE) {
-  lst <- list(...)
+  lst <- lapply(
+    list(...),
+    function(x) {
+      list(
+        values = as.character(x),
+        interpretation_details = attr(x, "interpretation_details")
+      )
+    }
+  )
+  x <- unlist(lapply(lst, `[[`, "values"), use.names = FALSE)
+  details <- lapply(lst, `[[`, "interpretation_details")
+  has_details <- vapply(details, is.data.frame, logical(1))
+  if (!any(has_details)) {
+    return(as_sir_structure(x))
+  }
 
-  # TODO for #170
+  # Pre-allocate details (no Map, no matrix allocation)
-  # guideline <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$guideline %or% NA_character_)
+  combined_details <- do.call(rbind, lapply(seq_along(details), function(i) {
-  # mo <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$mo %or% NA_character_)
+    d <- details[[i]]
-  # ab <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ab %or% NA_character_)
+    if (is.null(d)) {
-  # method <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$method %or% NA_character_)
+      # generate NA rows of correct length, but fast
-  # ref_tbl <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_tbl %or% NA_character_)
+      n <- length(details[[i]])
-  # ref_breakpoints <- vapply(FUN.VALUE = character(1), lst, function(x) attributes(x)$ref_breakpoints %or% NA_character_)
+      as.data.frame(matrix(NA, nrow = n, ncol = 0))
+    } else {
+      d
+    }
+  }))
 
-  out <- as.sir(unlist(lapply(list(...), as.character)))
+  attr(x, "interpretation_details") <- combined_details
-
+  as_sir_structure(x)
-  # TODO for #170
-  # if (!all(is.na(guideline))) {
-  #   attributes(out)$guideline <- guideline
-  #   attributes(out)$mo <- mo
-  #   attributes(out)$ab <- ab
-  #   attributes(out)$method <- method
-  #   attributes(out)$ref_tbl <- ref_tbl
-  #   attributes(out)$ref_breakpoints <- ref_breakpoints
-  # }
-
-  out
 }
 
 #' @method unique sir

R/sir_calc.R

@@ -257,12 +257,15 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
   data <- as.data.frame(data, stringsAsFactors = FALSE)
 
   for (i in seq_len(ncol(data))) {
-    data[, i] <- as.character(as.sir(data[, i, drop = TRUE]))
+    # transform SIR columns
-    if (isTRUE(combine_SI)) {
+    if (is.sir(data[, i, drop = TRUE])) {
-      if ("SDD" %in% data[, i, drop = TRUE] && message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
+      data[, i] <- as.character(data[, i, drop = 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)
+      if (isTRUE(combine_SI)) {
+        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)
+        }
+        data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
       }
-      data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
     }
   }
 

R/tidymodels.R

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

data-raw/_generate_python_wrapper.sh

@@ -56,7 +56,8 @@ os.makedirs(r_lib_path, exist_ok=True)
 os.environ['R_LIBS_SITE'] = r_lib_path
 
 from rpy2 import robjects
-from rpy2.robjects import pandas2ri
+from rpy2.robjects.conversion import localconverter
+from rpy2.robjects import default_converter, numpy2ri, pandas2ri
 from rpy2.robjects.packages import importr, isinstalled
 
 # Import base and utils
@@ -94,27 +95,26 @@ if r_amr_version != python_amr_version:
 print(f"AMR: Setting up R environment and AMR datasets...", flush=True)
 
 # Activate the automatic conversion between R and pandas DataFrames
-pandas2ri.activate()
+with localconverter(default_converter + numpy2ri.converter + pandas2ri.converter):
+    # example_isolates
+    example_isolates = robjects.r('''
+    df <- AMR::example_isolates
+    df[] <- lapply(df, function(x) {
+        if (inherits(x, c("Date", "POSIXt", "factor"))) {
+            as.character(x)
+        } else {
+            x
+        }
+    })
+    df <- df[, !sapply(df, is.list)]
+    df
+    ''')
+    example_isolates['date'] = pd.to_datetime(example_isolates['date'])
 
-# example_isolates
+    # microorganisms
-example_isolates = pandas2ri.rpy2py(robjects.r('''
+    microorganisms = robjects.r('AMR::microorganisms[, !sapply(AMR::microorganisms, is.list)]')
-df <- AMR::example_isolates
+    antimicrobials = robjects.r('AMR::antimicrobials[, !sapply(AMR::antimicrobials, is.list)]')
-df[] <- lapply(df, function(x) {
+    clinical_breakpoints = robjects.r('AMR::clinical_breakpoints[, !sapply(AMR::clinical_breakpoints, is.list)]')
-    if (inherits(x, c("Date", "POSIXt", "factor"))) {
-        as.character(x)
-    } else {
-        x
-    }
-})
-df <- df[, !sapply(df, is.list)]
-df
-'''))
-example_isolates['date'] = pd.to_datetime(example_isolates['date'])
-
-# microorganisms
-microorganisms = pandas2ri.rpy2py(robjects.r('AMR::microorganisms[, !sapply(AMR::microorganisms, is.list)]'))
-antimicrobials = pandas2ri.rpy2py(robjects.r('AMR::antimicrobials[, !sapply(AMR::antimicrobials, is.list)]'))
-clinical_breakpoints = pandas2ri.rpy2py(robjects.r('AMR::clinical_breakpoints[, !sapply(AMR::clinical_breakpoints, is.list)]'))
 
 base.options(warn = 0)
 
@@ -129,16 +129,15 @@ echo "from .datasets import clinical_breakpoints" >> $init_file
 
 # Write header to the functions Python file, including the convert_to_python function
 cat <<EOL > "$functions_file"
+import functools
 import rpy2.robjects as robjects
 from rpy2.robjects.packages import importr
 from rpy2.robjects.vectors import StrVector, FactorVector, IntVector, FloatVector, DataFrame
-from rpy2.robjects import pandas2ri
+from rpy2.robjects.conversion import localconverter
+from rpy2.robjects import default_converter, numpy2ri, pandas2ri
 import pandas as pd
 import numpy as np
 
-# Activate automatic conversion between R data frames and pandas data frames
-pandas2ri.activate()
-
 # Import the AMR R package
 amr_r = importr('AMR')
 
@@ -156,10 +155,8 @@ def convert_to_python(r_output):
         return list(r_output)  # Convert to a Python list of integers or floats
     
     # Check if it's a pandas-compatible R data frame
-    elif isinstance(r_output, pd.DataFrame):
+    elif isinstance(r_output, (pd.DataFrame, DataFrame)):
         return r_output  # Return as pandas DataFrame (already converted by pandas2ri)
-    elif isinstance(r_output, DataFrame):
-        return pandas2ri.rpy2py(r_output) # Return as pandas DataFrame
 
     # Check if the input is a NumPy array and has a string data type
     if isinstance(r_output, np.ndarray) and np.issubdtype(r_output.dtype, np.str_):
@@ -167,6 +164,15 @@ def convert_to_python(r_output):
     
     # Fall-back
     return r_output
+
+def r_to_python(r_func):
+    """Decorator that runs an rpy2 function under a localconverter
+    and then applies convert_to_python to its output."""
+    @functools.wraps(r_func)
+    def wrapper(*args, **kwargs):
+        with localconverter(default_converter + numpy2ri.converter + pandas2ri.converter):
+            return convert_to_python(r_func(*args, **kwargs))
+    return wrapper
 EOL
 
 # Directory where the .Rd files are stored (update path as needed)
@@ -246,11 +252,12 @@ for rd_file in "$rd_dir"/*.Rd; do
         gsub("FALSE", "False", func_args)
         gsub("NULL", "None", func_args)
 
-        # Write the Python function definition to the output file
+        # Write the Python function definition to the output file, using decorator
-        print "def " func_name_py "(" func_args "):" >> "'"$functions_file"'"
+        print "@r_to_python" >> "'"$functions_file"'"  
-        print "    \"\"\"Please see our website of the R package for the full manual: https://amr-for-r.org\"\"\"" >> "'"$functions_file"'"
+        print "def " func_name_py "(" func_args "):" >> "'"$functions_file"'"  
-        print "    return convert_to_python(amr_r." func_name_py "(" func_args "))" >> "'"$functions_file"'"
+        print "    \"\"\"Please see our website of the R package for the full manual: https://amr-for-r.org\"\"\"" >> "'"$functions_file"'"  
-        
+        print "    return amr_r." func_name_py "(" func_args ")" >> "'"$functions_file"'"  
+
         print "from .functions import " func_name_py >> "'"$init_file"'"
     }
     ' "$rd_file"

index.Rmd

@@ -133,7 +133,7 @@ ggplot(data.frame(mic = some_mic_values,
                   sir = interpretation),
        aes(x = group, y = mic, colour = sir)) +
   theme_minimal() +
-  geom_boxplot(fill = NA, colour = "grey") +
+  geom_boxplot(fill = NA, colour = "grey30") +
   geom_jitter(width = 0.25) +
   
   # NEW scale function: plot MIC values to x, y, colour or fill

index.md

@@ -171,14 +171,14 @@ example_isolates %>%
   select(bacteria,
          aminoglycosides(),
          carbapenems())
-#> ℹ Using column 'mo' as input for mo_fullname()
+#> ℹ Using column 'mo' as input for `mo_fullname()`
-#> ℹ Using column 'mo' as input for mo_is_gram_negative()
+#> ℹ Using column 'mo' as input for `mo_is_gram_negative()`
-#> ℹ Using column 'mo' as input for mo_is_intrinsic_resistant()
+#> ℹ Using column 'mo' as input for `mo_is_intrinsic_resistant()`
 #> ℹ Determining intrinsic resistance based on 'EUCAST Expected Resistant
 #>   Phenotypes' v1.2 (2023). This note will be shown once per session.
-#> ℹ For aminoglycosides() using columns 'GEN' (gentamicin), 'TOB'
+#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
 #>   (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
-#> ℹ For carbapenems() using columns 'IPM' (imipenem) and 'MEM' (meropenem)
+#> ℹ For `carbapenems()` using columns 'IPM' (imipenem) and 'MEM' (meropenem)
 #> # A tibble: 35 × 7
 #>    bacteria                     GEN   TOB   AMK   KAN   IPM   MEM  
 #>    <chr>                        <sir> <sir> <sir> <sir> <sir> <sir>
@@ -215,9 +215,9 @@ output format automatically (such as markdown, LaTeX, HTML, etc.).
 ``` r
 antibiogram(example_isolates,
             antimicrobials = c(aminoglycosides(), carbapenems()))
-#> ℹ For aminoglycosides() using columns 'GEN' (gentamicin), 'TOB'
+#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
 #>   (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
-#> ℹ For carbapenems() using columns 'IPM' (imipenem) and 'MEM' (meropenem)
+#> ℹ For `carbapenems()` using columns 'IPM' (imipenem) and 'MEM' (meropenem)
 ```
 
 | Pathogen | Amikacin | Gentamicin | Imipenem | Kanamycin | Meropenem | Tobramycin |
@@ -289,7 +289,7 @@ ggplot(data.frame(mic = some_mic_values,
                   sir = interpretation),
        aes(x = group, y = mic, colour = sir)) +
   theme_minimal() +
-  geom_boxplot(fill = NA, colour = "grey") +
+  geom_boxplot(fill = NA, colour = "grey30") +
   geom_jitter(width = 0.25) +
   
   # NEW scale function: plot MIC values to x, y, colour or fill
@@ -340,15 +340,15 @@ out <- example_isolates %>%
   # calculate AMR using resistance(), over all aminoglycosides and polymyxins:
   summarise(across(c(aminoglycosides(), polymyxins()),
             resistance))
-#> ℹ For aminoglycosides() using columns 'GEN' (gentamicin), 'TOB'
+#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
 #>   (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
-#> ℹ For polymyxins() using column 'COL' (colistin)
+#> ℹ For `polymyxins()` using column 'COL' (colistin)
 #> Warning: There was 1 warning in `summarise()`.
 #> ℹ In argument: `across(c(aminoglycosides(), polymyxins()), resistance)`.
 #> ℹ In group 3: `ward = "Outpatient"`.
 #> Caused by warning:
 #> ! Introducing NA: only 23 results available for KAN in group: ward =
-#> "Outpatient" (minimum = 30).
+#> "Outpatient" (`minimum` = 30).
 out
 #> # A tibble: 3 × 6
 #>   ward         GEN   TOB   AMK   KAN   COL

man/age_groups.Rd

@@ -4,20 +4,23 @@
 \alias{age_groups}
 \title{Split Ages into Age Groups}
 \usage{
-age_groups(x, split_at = c(12, 25, 55, 75), na.rm = FALSE)
+age_groups(x, split_at = c(0, 12, 25, 55, 75), names = NULL,
+  na.rm = FALSE)
 }
 \arguments{
 \item{x}{Age, e.g. calculated with \code{\link[=age]{age()}}.}
 
 \item{split_at}{Values to split \code{x} at - the default is age groups 0-11, 12-24, 25-54, 55-74 and 75+. See \emph{Details}.}
 
+\item{names}{Optional names to be given to the various age groups.}
+
 \item{na.rm}{A \link{logical} to indicate whether missing values should be removed.}
 }
 \value{
 Ordered \link{factor}
 }
 \description{
-Split ages into age groups defined by the \code{split} argument. This allows for easier demographic (antimicrobial resistance) analysis.
+Split ages into age groups defined by the \code{split} argument. This allows for easier demographic (antimicrobial resistance) analysis. The function returns an ordered \link{factor}.
 }
 \details{
 To split ages, the input for the \code{split_at} argument can be:
@@ -41,6 +44,7 @@ age_groups(ages, 50)
 
 # split into 0-19, 20-49 and 50+
 age_groups(ages, c(20, 50))
+age_groups(ages, c(20, 50), names = c("Under 20 years", "20 to 50 years", "Over 50 years"))
 
 # split into groups of ten years
 age_groups(ages, 1:10 * 10)

man/amr-tidymodels.Rd

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

man/as.sir.Rd

@@ -70,7 +70,7 @@ is_sir_eligible(x, threshold = 0.05)
   language = get_AMR_locale(), verbose = FALSE, info = interactive(),
   parallel = FALSE, max_cores = -1, conserve_capped_values = NULL)
 
-sir_interpretation_history(clean = FALSE)
+sir_interpretation_history(sir_values = NULL, 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).}
@@ -147,6 +147,8 @@ The default \code{"standard"} setting ensures cautious handling of uncertain val
 
 \item{max_cores}{Maximum number of cores to use if \code{parallel = TRUE}. Use a negative value to subtract that number from the available number of cores, e.g. a value of \code{-2} on an 8-core machine means that at most 6 cores will be used. Defaults to \code{-1}. There will never be used more cores than variables to analyse. The available number of cores are detected using \code{\link[parallelly:availableCores]{parallelly::availableCores()}} if that package is installed, and base \R's \code{\link[parallel:detectCores]{parallel::detectCores()}} otherwise.}
 
+\item{sir_values}{SIR values that were interpreted from MIC or disk diffusion values using \code{\link[=as.sir]{as.sir()}}.}
+
 \item{clean}{A \link{logical} to indicate whether previously stored results should be forgotten after returning the 'logbook' with results.}
 }
 \value{

man/ggplot_sir.Rd

@@ -9,7 +9,7 @@ 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", SDD = "#8FD6C4", I = "#F6D55C", IR = "#ED553B",
+  = "#3CAEA3", SDD = "#8FD6C4", SI = "#3CAEA3", I = "#F6D55C", IR = "#ED553B",
   R = "#ED553B"), datalabels = TRUE, datalabels.size = 2.5,
   datalabels.colour = "grey15", title = NULL, subtitle = NULL,
   caption = NULL, x.title = "Antimicrobial", y.title = "Proportion", ...)

man/plot.Rd

@@ -210,6 +210,10 @@ if (require("ggplot2")) {
   # when providing the microorganism and antibiotic, colours will show interpretations:
   autoplot(some_mic_values, mo = "Escherichia coli", ab = "cipro")
 }
+if (require("ggplot2")) {
+  autoplot(some_mic_values, mo = "Staph aureus", ab = "Ceftaroline", guideline = "CLSI")
+}
+
 if (require("ggplot2")) {
   # support for 27 languages, various guidelines, and many options
   autoplot(some_disk_values,
@@ -267,7 +271,7 @@ if (require("ggplot2")) {
     aes(group, mic)
   ) +
     geom_boxplot() +
-    geom_violin(linetype = 2, colour = "grey", fill = NA) +
+    geom_violin(linetype = 2, colour = "grey30", fill = NA) +
     scale_y_mic()
 }
 if (require("ggplot2")) {
@@ -279,7 +283,7 @@ if (require("ggplot2")) {
     aes(group, mic)
   ) +
     geom_boxplot() +
-    geom_violin(linetype = 2, colour = "grey", fill = NA) +
+    geom_violin(linetype = 2, colour = "grey30", fill = NA) +
     scale_y_mic(mic_range = c(NA, 0.25))
 }
 
@@ -312,7 +316,7 @@ if (require("ggplot2")) {
     aes(x = group, y = mic, colour = sir)
   ) +
     theme_minimal() +
-    geom_boxplot(fill = NA, colour = "grey") +
+    geom_boxplot(fill = NA, colour = "grey30") +
     geom_jitter(width = 0.25)
 
   plain

pkgdown/extra.css

@@ -190,6 +190,15 @@ this shows on top of every sidebar to the right
   }
 }
 
+.template-reference-topic h3,
+.template-reference-topic h3 code {
+  color: var(--amr-green-dark) !important;
+}
+.template-reference-topic h3 {
+  font-weight: normal;
+  margin-top: 2rem;
+}
+
 /* replace 'Developers' with 'Maintainers' */
 .developers h2 {
   display: none;