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

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")]