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

(v1.1.0.9004) lose dependencies

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-05-16 13:05:47 +02:00
parent 9fce546901
commit 7f3da74b17
111 changed files with 3211 additions and 2345 deletions
Download Patch File Download Diff File Expand all files Collapse all files

131
R/eucast_rules.R
View File

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