(v2.1.1.9274) Improve is_sir_eligible, rename verbose MDRO output

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: AMR
-Version: 2.1.1.9273
-Date: 2025-05-05
+Version: 2.1.1.9274
+Date: 2025-05-12
 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

NEWS.md

@@ -1,4 +1,4 @@
-# AMR 2.1.1.9273
+# AMR 2.1.1.9274
 
 *(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support! Install this beta using [the instructions here](https://amr-for-r.org/#get-this-package).)*
 

R/ab.R

@@ -652,7 +652,7 @@ generalise_antibiotic_name <- function(x) {
   # replace more than 1 space
   x <- trimws(gsub(" +", " ", x, perl = TRUE))
   # remove last couple of words if they numbers or units
-  x <- gsub(" ([0-9]{3,99}|U?M?C?G)+$", "", x)
+  x <- gsub("( ([0-9]{3,}|U?M?C?G|L))+$", "", x, perl = TRUE)
   # move HIGH to end
   x <- trimws(gsub("(.*) HIGH(.*)", "\\1\\2 HIGH", x, perl = TRUE))
   x

R/mdro.R

@@ -354,7 +354,7 @@ mdro <- function(x = NULL,
         "row_number",
         "MDRO",
         "reason",
-        "columns_nonsusceptible"
+        "all_nonsusceptible_columns"
       )])
     } else {
       return(x$MDRO)
@@ -762,7 +762,7 @@ mdro <- function(x = NULL,
         ),
         stringsAsFactors = FALSE
       )
-      x[rows, "columns_nonsusceptible"] <<- vapply(
+      x[rows, "all_nonsusceptible_columns"] <<- vapply(
         FUN.VALUE = character(1),
         rows,
         function(row, group_vct = cols_ab) {
@@ -773,7 +773,7 @@ mdro <- function(x = NULL,
           )
           paste(
             sort(c(
-              unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
+              unlist(strsplit(x[row, "all_nonsusceptible_columns", drop = TRUE], ", ", fixed = TRUE)),
               names(cols_nonsus)[cols_nonsus]
             )),
             collapse = ", "
@@ -844,7 +844,7 @@ mdro <- function(x = NULL,
       )
 
       if (isTRUE(verbose)) {
-        x[rows, "columns_nonsusceptible"] <<- vapply(
+        x[rows, "all_nonsusceptible_columns"] <<- vapply(
           FUN.VALUE = character(1),
           rows,
           function(row, group_vct = lst_vector) {
@@ -891,7 +891,7 @@ mdro <- function(x = NULL,
   x$MDRO <- ifelse(!is.na(x$genus), 1, NA_integer_)
   x$row_number <- seq_len(nrow(x))
   x$reason <- NA_character_
-  x$columns_nonsusceptible <- ""
+  x$all_nonsusceptible_columns <- ""
 
   if (guideline$code == "cmi2012") {
     # CMI, 2012 ---------------------------------------------------------------
@@ -1948,7 +1948,7 @@ mdro <- function(x = NULL,
       "microorganism",
       "MDRO",
       "reason",
-      "columns_nonsusceptible"
+      "all_nonsusceptible_columns"
     ),
     drop = FALSE
     ]
@@ -2115,19 +2115,19 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
     out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
   }
 
-  columns_nonsusceptible <- as.data.frame(t(df[, is.sir(df), drop = FALSE] == "R"))
-  columns_nonsusceptible <- vapply(
+  all_nonsusceptible_columns <- as.data.frame(t(df[, is.sir(df), drop = FALSE] == "R"))
+  all_nonsusceptible_columns <- vapply(
     FUN.VALUE = character(1),
-    columns_nonsusceptible,
-    function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ")
+    all_nonsusceptible_columns,
+    function(x) paste0(rownames(all_nonsusceptible_columns)[which(x)], collapse = " ")
   )
-  columns_nonsusceptible[is.na(out)] <- NA_character_
+  all_nonsusceptible_columns[is.na(out)] <- NA_character_
 
   data.frame(
     row_number = seq_len(NROW(df)),
     MDRO = out,
     reason = reasons,
-    columns_nonsusceptible = columns_nonsusceptible,
+    all_nonsusceptible_columns = all_nonsusceptible_columns,
     stringsAsFactors = FALSE
   )
 }

R/sir.R

@@ -161,7 +161,7 @@
 #'
 #' 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% invalid antimicrobial interpretations (not S and/or I and/or R and/or NI and/or SDD), 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.
+#' 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:
 #' In 2019, the European Committee on Antimicrobial Susceptibility Testing (EUCAST) has decided to change the definitions of susceptibility testing categories S, I, and R (<https://www.eucast.org/newsiandr>).
 #'
@@ -387,7 +387,7 @@ as_sir_structure <- function(x,
                              method = NULL,
                              ref_tbl = NULL,
                              ref_breakpoints = NULL) {
-  out <- structure(
+  structure(
     factor(as.character(unlist(unname(x))),
       levels = c("S", "SDD", "I", "R", "NI"),
       ordered = TRUE
@@ -445,9 +445,9 @@ is_sir_eligible <- function(x, threshold = 0.05) {
   %in% class(x))) {
     # no transformation needed
     return(FALSE)
-  } else if (all(x %in% c("S", "SDD", "I", "R", "NI", NA)) & !all(is.na(x))) {
+  } else if (!all(is.na(x)) && all(toupper(x) %in% c("S", "SDD", "I", "R", "NI", NA))) {
     return(TRUE)
-  } else if (!any(c("S", "SDD", "I", "R", "NI") %in% x, na.rm = TRUE) & !all(is.na(x))) {
+  } else if (!all(is.na(x)) && !any(c("S", "SDD", "I", "R", "NI") %in% gsub("([SIR])\\1+", "\\1", gsub("[^A-Z]", "", toupper(x), perl = TRUE), perl = TRUE), na.rm = TRUE)) {
     return(FALSE)
   } else {
     x <- x[!is.na(x) & !is.null(x) & !x %in% c("", "-", "NULL")]

man/as.sir.Rd

@@ -249,7 +249,7 @@ The function \code{\link[=is.sir]{is.sir()}} detects if the input contains class
 
 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\% invalid antimicrobial interpretations (not S and/or I and/or R and/or NI and/or SDD), 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.
+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.
 }
 
 \code{NA_sir_} is a missing value of the new \code{sir} class, analogous to e.g. base \R's \code{\link[base:NA]{NA_character_}}.

tests/testthat/test-mdro.R

@@ -282,6 +282,11 @@ test_that("test-mdro.R", {
   #   info = FALSE
   # ))
 
+  expect_equal(
+    colnames(suppressWarnings(mdro(example_isolates[1:10, ], verbose = TRUE, info = FALSE))),
+    c("row_number", "microorganism", "MDRO", "reason", "all_nonsusceptible_columns")
+  )
+
   # print groups
   if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
     expect_output(x <- mdro(example_isolates %>% group_by(ward), info = TRUE, pct_required_classes = 0))