1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 15:41:56 +02:00

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

This commit is contained in:
2025-05-12 12:35:11 +02:00
parent 3f9012dc47
commit 7d45ca9fbf
7 changed files with 26 additions and 21 deletions

2
R/ab.R
View File

@ -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

View File

@ -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
)
}

View File

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