P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 16:42:10 +02:00
Code Releases Activity

(v1.3.0.9028) eucast fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-09-24 12:38:13 +02:00
parent 027215ed94
commit 1d982a82b4
24 changed files with 121 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

33
R/eucast_rules.R
View File

@ -136,6 +136,11 @@ eucast_rules <- function(x,
version_expertrules = 3.2,
...) {
x_deparsed <- deparse(substitute(x))
if (!x_deparsed %like% "[a-z]") {
x_deparsed <- "your_data"
}
check_dataset_integrity()
version_breakpoints <- as.double(version_breakpoints)
@ -152,12 +157,12 @@ eucast_rules <- function(x,
rules <- getOption("AMR.eucast_rules")
}
if (verbose == TRUE & info == TRUE) {
if (interactive() & verbose == TRUE & info == TRUE) {
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?")
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion) & interactive()) {
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Using verbose = TRUE with eucast_rules()", txt)
} else {
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
@ -504,6 +509,7 @@ eucast_rules <- function(x,
paste(collapse = ", ")
x <- gsub("_", " ", x, fixed = TRUE)
x <- gsub("except CAZ", paste("except", ab_name("CAZ", language = NULL, tolower = TRUE)), x, fixed = TRUE)
x <- gsub("cephalosporins (1st|2nd|3rd|4th|5th)", "cephalosporins (\\1 gen.)", x)
x
}
format_antibiotic_names <- function(ab_names, ab_results) {
@ -881,9 +887,13 @@ eucast_rules <- function(x,
rownames(verbose_info) <- NULL
affected <- x.bak[which(x.bak$`.rowid` %in% x$`.rowid`), , drop = FALSE]
rows_affected <- as.integer(rownames(affected))
verbose_info <- data.frame(row = rows_affected, rowid = affected[, ".rowid", drop = TRUE]) %pm>%
pm_left_join(verbose_info, by = "rowid") %pm>%
verbose_info <- verbose_info %pm>%
pm_left_join(data.frame(row = rows_affected,
rowid = affected[, ".rowid", drop = TRUE],
stringsAsFactors = FALSE),
by = "rowid") %pm>%
pm_select(-rowid) %pm>%
pm_select(row, pm_everything()) %pm>%
pm_filter(!is.na(new)) %pm>%
pm_arrange(row, rule_group, rule_name, col)
@ -919,7 +929,7 @@ eucast_rules <- function(x,
pm_count(new, name = "n")
cat(paste(" -",
paste0(formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
" added as ", added_summary$new), collapse = "\n"))
" added as ", paste0('"', added_summary$new, '"')), collapse = "\n"))
}
# print changed values
@ -942,7 +952,7 @@ eucast_rules <- function(x,
pm_count(old, new, name = "n")
cat(paste(" -",
paste0(formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ",
changed_summary$old, " to ", changed_summary$new), collapse = "\n"))
paste0('"', changed_summary$old, '"'), " to ", paste0('"', changed_summary$new, '"')), collapse = "\n"))
cat("\n")
}
@ -955,9 +965,12 @@ eucast_rules <- function(x,
}
}
if (isTRUE(warn_lacking_rsi_class)) {
warning("Not all columns with antimicrobial results are of class <rsi>.\n",
"Transform eligible columns to class <rsi> on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)",
unique_cols <- colnames(x.bak)[colnames(x.bak) %in% verbose_info$col]
warning("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
" ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" ", x_deparsed, " %>% as.rsi(", unique_cols[1], ":", unique_cols[length(unique_cols)], ")",
call. = FALSE)
}
@ -1010,7 +1023,7 @@ edit_rsi <- function(x,
if (length(rows) > 0 & length(cols) > 0) {
new_edits <- x
if (any(!sapply(x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
track_changes$warn <- TRUE
track_changes$rsi_warn <- TRUE
}
tryCatch(
# insert into original table
@ -1044,7 +1057,7 @@ edit_rsi <- function(x,
)
track_changes$output <- new_edits
if (isTRUE(info) && isFALSE(all.equal(x, track_changes$output))) {
if (isTRUE(info) && !isTRUE(all.equal(x, track_changes$output))) {
get_original_rows <- function(rowids) {
as.integer(rownames(original_data[which(original_data$.rowid %in% rowids), , drop = FALSE]))
}

60
R/rsi.R
View File

@ -33,7 +33,7 @@
#' @param conserve_capped_values a logical to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S"
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a logical to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on 'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes', version `r EUCAST_VERSION_EXPERT_RULES`.
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, please see *Examples*
#' @param ... parameters passed on to methods
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection like `AMX:VAN`). Otherwise: parameters passed on to methods.
#' @details
#' ## How it works
#'
@ -86,7 +86,7 @@
#' A microorganism is categorised as *Susceptible, Increased exposure* when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.
#'
#' This AMR package honours this new insight. Use [susceptibility()] (equal to [proportion_SI()]) to determine antimicrobial susceptibility and [count_susceptible()] (equal to [count_SI()]) to count susceptible isolates.
#' @return Ordered factor with new class [`rsi`]
#' @return Ordered [factor] with new class [`rsi`]
#' @aliases rsi
#' @export
#' @seealso [as.mic()], [as.disk()], [as.mo()]
@ -150,7 +150,7 @@
#'
#' as.rsi(c("S", "I", "R", "A", "B", "C"))
#' as.rsi("<= 0.002; S") # will return "S"
#'
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
#' is.rsi(rsi_data)
#' plot(rsi_data) # for percentages
@ -160,6 +160,9 @@
#' library(dplyr)
#' example_isolates %>%
#' mutate_at(vars(PEN:RIF), as.rsi)
#' # same:
#' example_isolates %>%
#' as.rsi(PEN:RIF)
#'
#' # fastest way to transform all columns with already valid AMR results to class `rsi`:
#' example_isolates %>%
@ -418,13 +421,14 @@ as.rsi.disk <- function(x,
#' @rdname as.rsi
#' @export
as.rsi.data.frame <- function(x,
as.rsi.data.frame <- function(x,
...,
col_mo = NULL,
guideline = "EUCAST",
uti = NULL,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
...) {
add_intrinsic_resistance = FALSE) {
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@ -471,38 +475,46 @@ as.rsi.data.frame <- function(x,
}
i <- 0
sel <- colnames(pm_select(x, ...))
ab_cols <- colnames(x)[sapply(x, function(y) {
i <<- i + 1
check <- is.mic(y) | is.disk(y)
ab <- colnames(x)[i]
ab_coerced <- suppressWarnings(as.ab(ab))
if (is.na(ab_coerced)) {
# not even a valid AB code
return(FALSE)
} else if (!check & all_valid_mics(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
return(TRUE)
} else if (!check & all_valid_disks(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
return(TRUE)
if (length(sel) == 0 || (length(sel) > 0 && ab %in% sel)) {
ab_coerced <- suppressWarnings(as.ab(ab))
if (is.na(ab_coerced) | !ab %in% sel) {
# not even a valid AB code
return(FALSE)
} else {
if (!check & all_valid_mics(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains MIC values.")))
} else if (!check & all_valid_disks(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") contains disk zones.")))
} else if (!is.rsi(y)) {
message(font_blue(paste0("NOTE: Assuming column `", ab, "` (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ") must be cleaned to valid R/SI values.")))
}
return(TRUE)
}
} else {
return(check)
return(FALSE)
}
})]
stop_if(length(ab_cols) == 0,
"no columns with MIC values or disk zones found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
"no columns with MIC values, disk zones or antibiotic column names found in this data set. Use as.mic() or as.disk() to transform antimicrobial columns.")
# set type per column
types <- character(length(ab_cols))
types[sapply(x[, ab_cols], is.mic)] <- "mic"
types[types == "" & sapply(x[, ab_cols], all_valid_mics)] <- "mic"
types[sapply(x[, ab_cols], is.disk)] <- "disk"
types[types == "" & sapply(x[, ab_cols], all_valid_disks)] <- "disk"
types[types == "" & !sapply(x[, ab_cols], is.rsi)] <- "rsi"
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
@ -518,6 +530,8 @@ as.rsi.data.frame <- function(x,
ab = ab_cols[i],
guideline = guideline,
uti = uti)
} else if (types[i] == "rsi") {
x[, ab_cols[i]] <- as.rsi.default(x = x %pm>% pm_pull(ab_cols[i]))
}
}