mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 04:42:22 +02:00
(v0.7.1.9032) eucast_rules() improvements
This commit is contained in:
204
R/eucast_rules.R
204
R/eucast_rules.R
@ -29,7 +29,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
|
||||
#' @param x data with antibiotic columns, like e.g. \code{AMX} and \code{AMC}
|
||||
#' @param info print progress
|
||||
#' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")}
|
||||
#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a \code{data.frame} with extensive info about which rows and columns would be effected and in which way.
|
||||
#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way.
|
||||
#' @param ... column name of an antibiotic, see section Antibiotics
|
||||
#' @inheritParams first_isolate
|
||||
#' @details
|
||||
@ -41,7 +41,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
|
||||
#' @section Antibiotics:
|
||||
#' To define antibiotics column names, leave as it is to determine it automatically with \code{\link{guess_ab_col}} or input a text (case-insensitive), or use \code{NULL} to skip a column (e.g. \code{TIC = NULL} to skip ticarcillin). Manually defined but non-existing columns will be skipped with a warning.
|
||||
#'
|
||||
#' The following antibiotics are used for the functions \code{\link{eucast_rules}} and \code{\link{mdro}}. These are shown in the format '\strong{antimicrobial ID}: name (\emph{ATC code})', sorted by name:
|
||||
#' The following antibiotics are used for the functions \code{\link{eucast_rules}} and \code{\link{mdro}}. These are shown below in the format '\strong{antimicrobial ID}: name (\emph{ATC code})', sorted by name:
|
||||
#'
|
||||
#' \strong{AMK}: amikacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB06}{J01GB06}),
|
||||
#' \strong{AMX}: amoxicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA04}{J01CA04}),
|
||||
@ -175,9 +175,11 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
|
||||
#' # 5 Pseudomonas aeruginosa R R - - R R R
|
||||
#'
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # do not apply EUCAST rules, but rather get a data.frame
|
||||
#' # with 18 rows, containing all details about the transformations:
|
||||
#' c <- eucast_rules(a, verbose = TRUE)
|
||||
#' }
|
||||
eucast_rules <- function(x,
|
||||
col_mo = NULL,
|
||||
info = TRUE,
|
||||
@ -186,7 +188,7 @@ eucast_rules <- function(x,
|
||||
...) {
|
||||
|
||||
if (verbose == TRUE & interactive()) {
|
||||
txt <- paste0("WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form: with extensive info about which rows and columns would be effected and in which way.",
|
||||
txt <- paste0("WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way.",
|
||||
"\n\nThis may overwrite your existing data if you use e.g.:",
|
||||
"\ndata <- eucast_rules(data, verbose = TRUE)\n\nDo you want to continue?")
|
||||
if ("rstudioapi" %in% rownames(installed.packages())) {
|
||||
@ -202,7 +204,7 @@ eucast_rules <- function(x,
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data frame.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
@ -211,40 +213,59 @@ eucast_rules <- function(x,
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) {
|
||||
stop("`rules` must be one or more of: 'breakpoints', 'expert', 'other', 'all'.")
|
||||
}
|
||||
|
||||
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set")
|
||||
}
|
||||
|
||||
|
||||
decimal.mark <- getOption("OutDec")
|
||||
big.mark <- ifelse(decimal.mark != ",", ",", ".")
|
||||
formatnr <- function(x) {
|
||||
trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
|
||||
}
|
||||
|
||||
|
||||
warned <- FALSE
|
||||
|
||||
|
||||
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") }
|
||||
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE }
|
||||
txt_ok <- function(no_of_changes) {
|
||||
txt_ok <- function(no_added, no_changed) {
|
||||
if (warned == FALSE) {
|
||||
if (no_of_changes > 0) {
|
||||
if (no_of_changes == 1) {
|
||||
cat(blue(" (1 value changed)\n"))
|
||||
} else {
|
||||
cat(blue(paste0(" (", formatnr(no_of_changes), " values changed)\n")))
|
||||
}
|
||||
if (no_added + no_changed == 0) {
|
||||
cat(green(" (no changes)\n"))
|
||||
} else {
|
||||
cat(green(" (no values changed)\n"))
|
||||
# opening
|
||||
cat(blue(" ("))
|
||||
# additions
|
||||
if (no_added > 0) {
|
||||
if (no_added == 1) {
|
||||
cat(blue("1 value added"))
|
||||
} else {
|
||||
cat(blue(formatnr(no_added), "values added"))
|
||||
}
|
||||
}
|
||||
# separator
|
||||
if (no_added > 0 & no_changed > 0) {
|
||||
cat(blue(", "))
|
||||
}
|
||||
# changes
|
||||
if (no_changed > 0) {
|
||||
if (no_changed == 1) {
|
||||
cat(blue("1 value changed"))
|
||||
} else {
|
||||
cat(blue(formatnr(no_changed), "values changed"))
|
||||
}
|
||||
}
|
||||
# closing
|
||||
cat(blue(")\n"))
|
||||
}
|
||||
warned <<- FALSE
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
soft_dependencies = c("AMC",
|
||||
"AMK",
|
||||
@ -312,7 +333,7 @@ eucast_rules <- function(x,
|
||||
hard_dependencies = NULL,
|
||||
verbose = verbose,
|
||||
...)
|
||||
|
||||
|
||||
AMC <- cols_ab['AMC']
|
||||
AMK <- cols_ab['AMK']
|
||||
AMP <- cols_ab['AMP']
|
||||
@ -376,27 +397,27 @@ eucast_rules <- function(x,
|
||||
TOB <- cols_ab['TOB']
|
||||
TZP <- cols_ab['TZP']
|
||||
VAN <- cols_ab['VAN']
|
||||
|
||||
|
||||
ab_missing <- function(ab) {
|
||||
all(ab %in% c(NULL, NA))
|
||||
}
|
||||
|
||||
|
||||
verbose_info <- data.frame(row = integer(0),
|
||||
col = character(0),
|
||||
mo_fullname = character(0),
|
||||
old = character(0),
|
||||
new = character(0),
|
||||
old = as.rsi(character(0)),
|
||||
new = as.rsi(character(0)),
|
||||
rule = character(0),
|
||||
rule_group = character(0),
|
||||
rule_name = character(0),
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
# helper function for editing the table
|
||||
edit_rsi <- function(to, rule, rows, cols) {
|
||||
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
before_df <- x_original
|
||||
|
||||
|
||||
tryCatch(
|
||||
# insert into original table
|
||||
x_original[rows, cols] <<- to,
|
||||
@ -420,7 +441,7 @@ eucast_rules <- function(x,
|
||||
ifelse(length(rows) > 10, "...", ""),
|
||||
' while writing value "', to,
|
||||
'" to column(s) `', paste(cols, collapse = "`, `"),
|
||||
"` (data class: ", paste(class(x_original), collapse = "/"), "):\n", e$message),
|
||||
"`:\n", e$message),
|
||||
call. = FALSE)
|
||||
}
|
||||
)
|
||||
@ -428,22 +449,23 @@ eucast_rules <- function(x,
|
||||
tryCatch(
|
||||
x[rows, cols] <<- x_original[rows, cols],
|
||||
error = function(e) {
|
||||
stop(paste0("Error in row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
|
||||
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
|
||||
'... while writing value "', to,
|
||||
'" to column(s) `', paste(cols, collapse = "`, `"),
|
||||
"` (data class:", paste(class(x), collapse = "/"), "):\n", e$message), call. = FALSE)
|
||||
"`:\n", e$message), call. = FALSE)
|
||||
}
|
||||
)
|
||||
|
||||
# before_df might not be a data.frame, but a tibble or data.table instead
|
||||
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
|
||||
no_of_changes_this_run <- 0
|
||||
track_changes <- list(added = 0,
|
||||
changed = 0)
|
||||
for (i in 1:length(cols)) {
|
||||
verbose_new <- data.frame(row = rows,
|
||||
col = cols[i],
|
||||
mo_fullname = x[rows, "fullname"],
|
||||
old = as.character(old[, cols[i]]),
|
||||
new = as.character(x[rows, cols[i]]),
|
||||
old = as.rsi(as.character(old[, cols[i]]), warn = FALSE),
|
||||
new = as.rsi(as.character(x[rows, cols[i]])),
|
||||
rule = strip_style(rule[1]),
|
||||
rule_group = strip_style(rule[2]),
|
||||
rule_name = strip_style(rule[3]),
|
||||
@ -452,18 +474,21 @@ eucast_rules <- function(x,
|
||||
verbose_new <- verbose_new %>% filter(old != new | is.na(old))
|
||||
# save changes to data set 'verbose_info'
|
||||
verbose_info <<- rbind(verbose_info, verbose_new)
|
||||
no_of_changes_this_run <- no_of_changes_this_run + nrow(verbose_new)
|
||||
# count adds and changes
|
||||
track_changes$added <- track_changes$added + verbose_new %>% filter(is.na(old)) %>% nrow()
|
||||
track_changes$changed <- track_changes$changed + verbose_new %>% filter(!is.na(old)) %>% nrow()
|
||||
}
|
||||
# after the applied changes: return number of (new) changes
|
||||
return(no_of_changes_this_run)
|
||||
# after the applied changes: return list with counts of added and changed
|
||||
return(track_changes)
|
||||
}
|
||||
# no changes were applied: return number of (new) changes: none.
|
||||
return(0)
|
||||
return(list(added = 0,
|
||||
changed = 0))
|
||||
}
|
||||
|
||||
|
||||
# save original table
|
||||
x_original <- x
|
||||
|
||||
|
||||
# join to microorganisms data set
|
||||
suppressWarnings(
|
||||
x <- x %>%
|
||||
@ -473,13 +498,13 @@ eucast_rules <- function(x,
|
||||
genus_species = paste(genus, species)) %>%
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
)
|
||||
|
||||
|
||||
if (info == TRUE) {
|
||||
cat(paste0(
|
||||
"\nRules by the ", bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", blue("http://eucast.org/"), "\n"))
|
||||
}
|
||||
|
||||
|
||||
# since ampicillin ^= amoxicillin, get the first from the latter (not in original EUCAST table)
|
||||
if (!ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
if (verbose == TRUE) {
|
||||
@ -501,7 +526,7 @@ eucast_rules <- function(x,
|
||||
message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
|
||||
AMP <- AMX
|
||||
}
|
||||
|
||||
|
||||
# antibiotic classes
|
||||
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
|
||||
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
|
||||
@ -516,7 +541,7 @@ eucast_rules <- function(x,
|
||||
ureidopenicillins <- c(PIP, TZP, AZL, MEZ)
|
||||
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
|
||||
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
|
||||
|
||||
|
||||
# Help function to get available antibiotic column names ------------------
|
||||
get_antibiotic_columns <- function(x, df) {
|
||||
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
|
||||
@ -538,11 +563,40 @@ eucast_rules <- function(x,
|
||||
sort() %>%
|
||||
paste(collapse = ", ")
|
||||
}
|
||||
|
||||
format_antibiotic_names <- function(ab_names, ab_results) {
|
||||
ab_names <- trimws(unlist(strsplit(ab_names, ",")))
|
||||
ab_results <- trimws(unlist(strsplit(ab_results, ",")))
|
||||
if (length(ab_results) == 1) {
|
||||
if (length(ab_names) == 1) {
|
||||
# like FOX S
|
||||
x <- paste(ab_names, "is")
|
||||
} else if (length(ab_names) == 2) {
|
||||
# like PEN,FOX S
|
||||
x <- paste(paste0(ab_names, collapse = " and "), "are both")
|
||||
} else {
|
||||
# like PEN,FOX,GEN S (although dependency on > 2 ABx does not exist at the moment)
|
||||
x <- paste(paste0(ab_names, collapse = " and "), "are all")
|
||||
}
|
||||
return(paste0(x, " '", ab_results, "'"))
|
||||
} else {
|
||||
if (length(ab_names) == 2) {
|
||||
# like PEN,FOX S,R
|
||||
paste0(ab_names[1], " is '", ab_results[1], "' and ",
|
||||
ab_names[2], " is '", ab_results[2], "'")
|
||||
} else {
|
||||
# like PEN,FOX,GEN S,R,R (although dependency on > 2 ABx does not exist at the moment)
|
||||
paste0(ab_names[1], " is '", ab_results[1], "' and ",
|
||||
ab_names[2], " is '", ab_results[2], "' and ",
|
||||
ab_names[3], " is '", ab_results[3], "'")
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
eucast_rules_df <- eucast_rules_file # internal data file
|
||||
no_of_changes <- 0
|
||||
no_added <- 0
|
||||
no_changed <- 0
|
||||
for (i in 1:nrow(eucast_rules_df)) {
|
||||
|
||||
|
||||
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"]
|
||||
rule_current <- eucast_rules_df[i, "reference.rule"]
|
||||
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"]
|
||||
@ -553,7 +607,8 @@ eucast_rules <- function(x,
|
||||
rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6]))
|
||||
} else {
|
||||
rule_text <- paste0("report as '", eucast_rules_df[i, 7], "' when ",
|
||||
get_antibiotic_names(eucast_rules_df[i, 4]), " is '", eucast_rules_df[i, 5], "': ",
|
||||
format_antibiotic_names(ab_names = get_antibiotic_names(eucast_rules_df[i, 4]),
|
||||
ab_results = eucast_rules_df[i, 5]), ": ",
|
||||
get_antibiotic_names(eucast_rules_df[i, 6]))
|
||||
}
|
||||
if (i == 1) {
|
||||
@ -564,7 +619,7 @@ eucast_rules <- function(x,
|
||||
rule_next <- ""
|
||||
rule_group_next <- ""
|
||||
}
|
||||
|
||||
|
||||
# don't apply rules if user doesn't want to apply them
|
||||
if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) {
|
||||
next
|
||||
@ -575,8 +630,8 @@ eucast_rules <- function(x,
|
||||
if (rule_group_current %like% "other" & !any(c("all", "other") %in% rules)) {
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
if (info == TRUE) {
|
||||
# Print rule (group) ------------------------------------------------------
|
||||
if (rule_group_current != rule_group_previous) {
|
||||
@ -604,11 +659,11 @@ eucast_rules <- function(x,
|
||||
warned <- FALSE
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Get rule from file ------------------------------------------------------
|
||||
col_mo_property <- eucast_rules_df[i, 1]
|
||||
like_is_one_of <- eucast_rules_df[i, 2]
|
||||
|
||||
|
||||
# be sure to comprise all coagulase-negative/-positive Staphylococci when they are mentioned
|
||||
if (eucast_rules_df[i, 3] %like% "coagulase-") {
|
||||
suppressWarnings(
|
||||
@ -633,7 +688,7 @@ eucast_rules <- function(x,
|
||||
}
|
||||
like_is_one_of <- "like"
|
||||
}
|
||||
|
||||
|
||||
if (like_is_one_of == "is") {
|
||||
mo_value <- paste0("^", eucast_rules_df[i, 3], "$")
|
||||
} else if (like_is_one_of == "one_of") {
|
||||
@ -647,12 +702,12 @@ eucast_rules <- function(x,
|
||||
} else {
|
||||
stop("invalid like_is_one_of", call. = FALSE)
|
||||
}
|
||||
|
||||
|
||||
source_antibiotics <- eucast_rules_df[i, 4]
|
||||
source_value <- trimws(unlist(strsplit(eucast_rules_df[i, 5], ",", fixed = TRUE)))
|
||||
target_antibiotics <- eucast_rules_df[i, 6]
|
||||
target_value <- eucast_rules_df[i, 7]
|
||||
|
||||
|
||||
if (is.na(source_antibiotics)) {
|
||||
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value),
|
||||
error = function(e) integer(0))
|
||||
@ -682,24 +737,28 @@ eucast_rules <- function(x,
|
||||
stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
cols <- get_antibiotic_columns(target_antibiotics, x)
|
||||
|
||||
|
||||
# Apply rule on data ------------------------------------------------------
|
||||
# this will return the unique number of changes
|
||||
no_of_changes <- no_of_changes + edit_rsi(to = target_value,
|
||||
rule = c(rule_text, rule_group_current, rule_current),
|
||||
rows = rows,
|
||||
cols = cols)
|
||||
|
||||
run_changes <- edit_rsi(to = target_value,
|
||||
rule = c(rule_text, rule_group_current, rule_current),
|
||||
rows = rows,
|
||||
cols = cols)
|
||||
no_added <- no_added + run_changes$added
|
||||
no_changed <- no_changed + run_changes$changed
|
||||
|
||||
# Print number of new changes ---------------------------------------------
|
||||
if (info == TRUE & rule_next != rule_current) {
|
||||
# print only on last one of rules in this group
|
||||
txt_ok(no_of_changes = no_of_changes)
|
||||
no_of_changes <- 0
|
||||
txt_ok(no_added = no_added, no_changed = no_changed)
|
||||
# and reset counters
|
||||
no_added <- 0
|
||||
no_changed <- 0
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Print overview ----------------------------------------------------------
|
||||
if (info == TRUE) {
|
||||
if (verbose == TRUE) {
|
||||
@ -707,19 +766,19 @@ eucast_rules <- function(x,
|
||||
} else {
|
||||
wouldve <- ""
|
||||
}
|
||||
|
||||
|
||||
verbose_info <- verbose_info %>%
|
||||
arrange(row, rule_group, rule_name, col)
|
||||
|
||||
|
||||
cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
|
||||
formatnr(n_distinct(verbose_info$row)),
|
||||
'out of', formatnr(nrow(x_original)),
|
||||
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
|
||||
|
||||
|
||||
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
|
||||
n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow()
|
||||
|
||||
|
||||
# print added values ----
|
||||
if (n_added == 0) {
|
||||
colour <- cat # is function
|
||||
@ -734,8 +793,6 @@ eucast_rules <- function(x,
|
||||
if (n_added > 0) {
|
||||
verbose_info %>%
|
||||
filter(is.na(old)) %>%
|
||||
# sort it well: S < I < R
|
||||
mutate(new = as.rsi(new)) %>%
|
||||
group_by(new) %>%
|
||||
summarise(n = n()) %>%
|
||||
mutate(plural = ifelse(n > 1, "s", ""),
|
||||
@ -744,7 +801,7 @@ eucast_rules <- function(x,
|
||||
paste(" -", ., collapse = "\n") %>%
|
||||
cat()
|
||||
}
|
||||
|
||||
|
||||
# print changed values ----
|
||||
if (n_changed == 0) {
|
||||
colour <- cat # is function
|
||||
@ -762,9 +819,6 @@ eucast_rules <- function(x,
|
||||
if (n_changed > 0) {
|
||||
verbose_info %>%
|
||||
filter(!is.na(old)) %>%
|
||||
# sort it well: S < I < R
|
||||
mutate(old = as.rsi(old),
|
||||
new = as.rsi(new)) %>%
|
||||
group_by(old, new) %>%
|
||||
summarise(n = n()) %>%
|
||||
mutate(plural = ifelse(n > 1, "s", ""),
|
||||
@ -775,14 +829,14 @@ eucast_rules <- function(x,
|
||||
cat("\n")
|
||||
}
|
||||
cat(paste0(silver(strrep("-", options()$width - 1)), "\n"))
|
||||
|
||||
|
||||
if (verbose == FALSE & nrow(verbose_info) > 0) {
|
||||
cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))
|
||||
} else if (verbose == TRUE) {
|
||||
cat(paste0("\nUsed 'Verbose mode' (", bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", bold("verbose = FALSE"), " to apply the rules on your data.\n\n"))
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Return data set ---------------------------------------------------------
|
||||
if (verbose == TRUE) {
|
||||
verbose_info
|
||||
|
||||
Reference in New Issue
Block a user