mirror of
https://github.com/msberends/AMR.git
synced 2025-07-10 13:01:58 +02:00
(v1.1.0.9004) lose dependencies
This commit is contained in:
131
R/eucast_rules.R
131
R/eucast_rules.R
@ -141,9 +141,6 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
|
||||
#' @aliases EUCAST
|
||||
#' @rdname eucast_rules
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
|
||||
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white red make_style
|
||||
#' @importFrom utils menu
|
||||
#' @return The input of `x`, possibly with edited values of antibiotics. Or, if `verbose = TRUE`, a [`data.frame`] with all original and new values of the affected bug-drug combinations.
|
||||
#' @source
|
||||
#' - EUCAST Expert Rules. Version 2.0, 2012. \cr
|
||||
@ -211,7 +208,7 @@ eucast_rules <- function(x,
|
||||
if ("rstudioapi" %in% rownames(utils::installed.packages())) {
|
||||
q_continue <- rstudioapi::showQuestion("Using verbose = TRUE with eucast_rules()", txt)
|
||||
} else {
|
||||
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
|
||||
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
|
||||
}
|
||||
if (q_continue %in% c(FALSE, 2)) {
|
||||
message("Cancelled, returning original data")
|
||||
@ -242,52 +239,50 @@ eucast_rules <- function(x,
|
||||
|
||||
decimal.mark <- getOption("OutDec")
|
||||
big.mark <- ifelse(decimal.mark != ",", ",", ".")
|
||||
formatnr <- function(x) {
|
||||
trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
|
||||
formatnr <- function(x, big = big.mark, dec = decimal.mark) {
|
||||
trimws(format(x, big.mark = big, decimal.mark = dec))
|
||||
}
|
||||
|
||||
grey <- make_style("grey")
|
||||
|
||||
warned <- FALSE
|
||||
|
||||
txt_error <- function() {
|
||||
if (info == TRUE) cat("", bgRed(white(" ERROR ")), "\n\n")
|
||||
if (info == TRUE) cat("", font_red_bg(font_white(" ERROR ")), "\n\n")
|
||||
}
|
||||
txt_warning <- function() {
|
||||
if (warned == FALSE) {
|
||||
if (info == TRUE) cat("", bgYellow(black(" WARNING ")))
|
||||
if (info == TRUE) cat("", font_yellow_bg(font_black(" WARNING ")))
|
||||
}
|
||||
warned <<- TRUE
|
||||
}
|
||||
txt_ok <- function(no_added, no_changed) {
|
||||
if (warned == FALSE) {
|
||||
if (no_added + no_changed == 0) {
|
||||
cat(pillar::style_subtle(" (no changes)\n"))
|
||||
cat(font_subtle(" (no changes)\n"))
|
||||
} else {
|
||||
# opening
|
||||
cat(grey(" ("))
|
||||
cat(font_grey(" ("))
|
||||
# additions
|
||||
if (no_added > 0) {
|
||||
if (no_added == 1) {
|
||||
cat(green("1 value added"))
|
||||
cat(font_green("1 value added"))
|
||||
} else {
|
||||
cat(green(formatnr(no_added), "values added"))
|
||||
cat(font_green(formatnr(no_added), "values added"))
|
||||
}
|
||||
}
|
||||
# separator
|
||||
if (no_added > 0 & no_changed > 0) {
|
||||
cat(grey(", "))
|
||||
cat(font_grey(", "))
|
||||
}
|
||||
# changes
|
||||
if (no_changed > 0) {
|
||||
if (no_changed == 1) {
|
||||
cat(blue("1 value changed"))
|
||||
cat(font_blue("1 value changed"))
|
||||
} else {
|
||||
cat(blue(formatnr(no_changed), "values changed"))
|
||||
cat(font_blue(formatnr(no_changed), "values changed"))
|
||||
}
|
||||
}
|
||||
# closing
|
||||
cat(grey(")\n"))
|
||||
cat(font_grey(")\n"))
|
||||
}
|
||||
warned <<- FALSE
|
||||
}
|
||||
@ -450,8 +445,11 @@ eucast_rules <- function(x,
|
||||
x_original[rows, cols] <<- to,
|
||||
warning = function(w) {
|
||||
if (w$message %like% "invalid factor level") {
|
||||
x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
|
||||
x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
|
||||
xyz <- sapply(cols, function(col) {
|
||||
x_original[, col] <<- factor(x = as.character(pull(x_original, col)), levels = c(to, levels(pull(x_original, col))))
|
||||
x[, col] <<- factor(x = as.character(pull(x, col)), levels = c(to, levels(pull(x, col))))
|
||||
invisible()
|
||||
})
|
||||
x_original[rows, cols] <<- to
|
||||
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE)
|
||||
txt_warning()
|
||||
@ -493,9 +491,9 @@ eucast_rules <- function(x,
|
||||
mo_fullname = x[rows, "fullname"],
|
||||
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]),
|
||||
rule = font_stripstyle(rule[1]),
|
||||
rule_group = font_stripstyle(rule[2]),
|
||||
rule_name = font_stripstyle(rule[3]),
|
||||
stringsAsFactors = FALSE)
|
||||
colnames(verbose_new) <- c("row", "col", "mo_fullname", "old", "new", "rule", "rule_group", "rule_name")
|
||||
verbose_new <- verbose_new %>% filter(old != new | is.na(old))
|
||||
@ -517,18 +515,16 @@ eucast_rules <- function(x,
|
||||
x_original <- x
|
||||
|
||||
# join to microorganisms data set
|
||||
suppressWarnings(
|
||||
x <- x %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", "")) %>%
|
||||
mutate(gramstain = mo_gramstain(pull(., col_mo), language = "en"),
|
||||
genus_species = paste(genus, species)) %>%
|
||||
as.data.frame(stringsAsFactors = FALSE)
|
||||
)
|
||||
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
x[, col_mo] <- as.mo(x[, col_mo, drop = TRUE])
|
||||
x <- x %>%
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", ""))
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE])
|
||||
x$genus_species <- paste(x$genus, x$species)
|
||||
|
||||
if (ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
|
||||
message(font_blue(paste0("NOTE: Using column `", font_bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
|
||||
AMP <- AMX
|
||||
}
|
||||
|
||||
@ -642,8 +638,8 @@ eucast_rules <- function(x,
|
||||
|
||||
if (info == TRUE & !rule_group_current %like% "other" & eucast_notification_shown == FALSE) {
|
||||
cat(paste0(
|
||||
"\n----\nRules by the ", bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", blue("http://eucast.org/"), "\n"))
|
||||
"\n----\nRules by the ", font_bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"),
|
||||
"\n", font_blue("http://eucast.org/"), "\n"))
|
||||
eucast_notification_shown <- TRUE
|
||||
}
|
||||
|
||||
@ -652,25 +648,23 @@ eucast_rules <- function(x,
|
||||
# Print rule (group) ------------------------------------------------------
|
||||
if (rule_group_current != rule_group_previous) {
|
||||
# is new rule group, one of Breakpoints, Expert Rules and Other
|
||||
cat(bold(
|
||||
case_when(
|
||||
rule_group_current %like% "breakpoint" ~
|
||||
paste0("\nEUCAST Clinical Breakpoints (",
|
||||
red(paste0("v", EUCAST_VERSION_BREAKPOINTS)), ")\n"),
|
||||
rule_group_current %like% "expert" ~
|
||||
cat(font_bold(
|
||||
ifelse(
|
||||
rule_group_current %like% "breakpoint",
|
||||
paste0("\nEUCAST Clinical Breakpoints (",
|
||||
font_red(paste0("v", EUCAST_VERSION_BREAKPOINTS)), ")\n"),
|
||||
ifelse(
|
||||
rule_group_current %like% "expert",
|
||||
paste0("\nEUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes (",
|
||||
red(paste0("v", EUCAST_VERSION_EXPERT_RULES)), ")\n"),
|
||||
TRUE ~
|
||||
"\nOther rules by this AMR package\n"
|
||||
)
|
||||
))
|
||||
font_red(paste0("v", EUCAST_VERSION_EXPERT_RULES)), ")\n"),
|
||||
"\nOther rules by this AMR package\n"))))
|
||||
}
|
||||
# Print rule -------------------------------------------------------------
|
||||
if (rule_current != rule_previous) {
|
||||
# is new rule within group, print its name
|
||||
if (rule_current %in% c(microorganisms$family,
|
||||
microorganisms$fullname)) {
|
||||
cat(italic(rule_current))
|
||||
cat(font_italic(rule_current))
|
||||
} else {
|
||||
cat(rule_current)
|
||||
}
|
||||
@ -789,8 +783,8 @@ eucast_rules <- function(x,
|
||||
verbose_info <- verbose_info %>%
|
||||
arrange(row, rule_group, rule_name, col)
|
||||
|
||||
cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(bold(paste("EUCAST rules", paste0(wouldve, "affected"),
|
||||
cat(paste0("\n", font_grey(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(font_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")))
|
||||
@ -802,62 +796,59 @@ eucast_rules <- function(x,
|
||||
if (n_added == 0) {
|
||||
colour <- cat # is function
|
||||
} else {
|
||||
colour <- green # is function
|
||||
colour <- font_green # is function
|
||||
}
|
||||
cat(colour(paste0("=> ", wouldve, "added ",
|
||||
bold(formatnr(verbose_info %>%
|
||||
font_bold(formatnr(verbose_info %>%
|
||||
filter(is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
"\n")))
|
||||
if (n_added > 0) {
|
||||
verbose_info %>%
|
||||
added_summary <- verbose_info %>%
|
||||
filter(is.na(old)) %>%
|
||||
group_by(new) %>%
|
||||
summarise(n = n()) %>%
|
||||
mutate(plural = ifelse(n > 1, "s", ""),
|
||||
txt = paste0(formatnr(n), " test result", plural, " added as ", new)) %>%
|
||||
pull(txt) %>%
|
||||
paste(" -", ., collapse = "\n") %>%
|
||||
cat()
|
||||
summarise(n = n())
|
||||
cat(paste(" -",
|
||||
paste0(formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
|
||||
" added as ", added_summary$new), collapse = "\n"))
|
||||
}
|
||||
|
||||
# print changed values ----
|
||||
if (n_changed == 0) {
|
||||
colour <- cat # is function
|
||||
} else {
|
||||
colour <- blue # is function
|
||||
colour <- font_blue # is function
|
||||
}
|
||||
if (n_added + n_changed > 0) {
|
||||
cat("\n")
|
||||
}
|
||||
cat(colour(paste0("=> ", wouldve, "changed ",
|
||||
bold(formatnr(verbose_info %>%
|
||||
font_bold(formatnr(verbose_info %>%
|
||||
filter(!is.na(old)) %>%
|
||||
nrow()), "test results"),
|
||||
"\n")))
|
||||
if (n_changed > 0) {
|
||||
verbose_info %>%
|
||||
changed_summary <- verbose_info %>%
|
||||
filter(!is.na(old)) %>%
|
||||
group_by(old, new) %>%
|
||||
summarise(n = n()) %>%
|
||||
mutate(plural = ifelse(n > 1, "s", ""),
|
||||
txt = paste0(formatnr(n), " test result", plural, " changed from ", old, " to ", new)) %>%
|
||||
pull(txt) %>%
|
||||
paste(" -", ., collapse = "\n") %>%
|
||||
cat()
|
||||
summarise(n = 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"))
|
||||
cat("\n")
|
||||
}
|
||||
cat(paste0(grey(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(paste0(font_grey(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"))
|
||||
cat(paste("\nUse", font_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"))
|
||||
cat(paste0("\nUsed 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data.\n\n"))
|
||||
}
|
||||
}
|
||||
|
||||
# Return data set ---------------------------------------------------------
|
||||
if (verbose == TRUE) {
|
||||
rownames(verbose_info) <- NULL
|
||||
verbose_info
|
||||
} else {
|
||||
x_original
|
||||
|
Reference in New Issue
Block a user