mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 11:11:54 +02:00
expert rules 12.0
This commit is contained in:
@ -30,6 +30,12 @@
|
||||
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and rsi_translation
|
||||
# (sourcing "data-raw/_pre_commit_hook.R" will process the TSV file)
|
||||
EUCAST_VERSION_BREAKPOINTS <- list(
|
||||
"12.0" = list(
|
||||
version_txt = "v12.0",
|
||||
year = 2022,
|
||||
title = "'EUCAST Clinical Breakpoint Tables'",
|
||||
url = "https://www.eucast.org/clinical_breakpoints/"
|
||||
),
|
||||
"11.0" = list(
|
||||
version_txt = "v11.0",
|
||||
year = 2021,
|
||||
|
@ -304,7 +304,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
|
||||
found <- found[1]
|
||||
|
||||
if (!is.null(found) && info == TRUE) {
|
||||
if (!is.null(found) && isTRUE(info)) {
|
||||
if (message_not_thrown_before("search_in_type", type)) {
|
||||
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
|
||||
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
|
||||
|
12
R/ab.R
12
R/ab.R
@ -132,7 +132,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_unknown_ATCs <- character(0)
|
||||
|
||||
note_if_more_than_one_found <- function(found, index, from_text) {
|
||||
if (initial_search == TRUE && isTRUE(length(from_text) > 1)) {
|
||||
if (isTRUE(initial_search) && isTRUE(length(from_text) > 1)) {
|
||||
abnames <- ab_name(from_text, tolower = TRUE, initial_search = FALSE)
|
||||
if (ab_name(found[1L], language = NULL) %like% "(clavulanic acid|avibactam)") {
|
||||
abnames <- abnames[!abnames %in% c("clavulanic acid", "avibactam")]
|
||||
@ -175,13 +175,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_new[is.na(x)] <- NA
|
||||
already_known[is.na(x)] <- FALSE
|
||||
|
||||
if (initial_search == TRUE && sum(already_known) < length(x)) {
|
||||
if (isTRUE(initial_search) && sum(already_known) < length(x)) {
|
||||
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
||||
on.exit(close(progress))
|
||||
}
|
||||
|
||||
for (i in which(!already_known)) {
|
||||
if (initial_search == TRUE) {
|
||||
if (isTRUE(initial_search)) {
|
||||
progress$tick()
|
||||
}
|
||||
|
||||
@ -316,7 +316,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# INITIAL SEARCH - More uncertain results ----
|
||||
|
||||
if (initial_search == TRUE && fast_mode == FALSE) {
|
||||
if (isTRUE(initial_search) && fast_mode == FALSE) {
|
||||
# only run on first try
|
||||
|
||||
# try by removing all spaces
|
||||
@ -487,12 +487,12 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||
}
|
||||
|
||||
if (initial_search == TRUE && sum(already_known) < length(x)) {
|
||||
if (isTRUE(initial_search) && sum(already_known) < length(x)) {
|
||||
close(progress)
|
||||
}
|
||||
|
||||
# save to package env to save time for next time
|
||||
if (initial_search == TRUE) {
|
||||
if (isTRUE(initial_search)) {
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
|
||||
AMR_env$ab_previously_coerced <- unique(rbind(AMR_env$ab_previously_coerced,
|
||||
data.frame(
|
||||
|
@ -685,7 +685,7 @@ all.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
# e.g., example_isolates %>% filter(all(carbapenems() == "R"))
|
||||
# so just return the vector as is, only correcting for na.rm
|
||||
out <- unclass(c(...))
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
out <- out[!is.na(out)]
|
||||
}
|
||||
out
|
||||
@ -699,7 +699,7 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
# e.g., example_isolates %>% filter(any(carbapenems() == "R"))
|
||||
# so just return the vector as is, only correcting for na.rm
|
||||
out <- unclass(c(...))
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
out <- out[!is.na(out)]
|
||||
}
|
||||
out
|
||||
|
12
R/av.R
12
R/av.R
@ -114,7 +114,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_unknown_ATCs <- character(0)
|
||||
|
||||
note_if_more_than_one_found <- function(found, index, from_text) {
|
||||
if (initial_search == TRUE && isTRUE(length(from_text) > 1)) {
|
||||
if (isTRUE(initial_search) && isTRUE(length(from_text) > 1)) {
|
||||
avnames <- av_name(from_text, tolower = TRUE, initial_search = FALSE)
|
||||
if (av_name(found[1L], language = NULL) %like% "(clavulanic acid|avibactam)") {
|
||||
avnames <- avnames[!avnames %in% c("clavulanic acid", "avibactam")]
|
||||
@ -157,13 +157,13 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_new[is.na(x)] <- NA
|
||||
already_known[is.na(x)] <- FALSE
|
||||
|
||||
if (initial_search == TRUE && sum(already_known) < length(x)) {
|
||||
if (isTRUE(initial_search) && sum(already_known) < length(x)) {
|
||||
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
||||
on.exit(close(progress))
|
||||
}
|
||||
|
||||
for (i in which(!already_known)) {
|
||||
if (initial_search == TRUE) {
|
||||
if (isTRUE(initial_search)) {
|
||||
progress$tick()
|
||||
}
|
||||
|
||||
@ -286,7 +286,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
|
||||
# INITIAL SEARCH - More uncertain results ----
|
||||
|
||||
if (initial_search == TRUE && fast_mode == FALSE) {
|
||||
if (isTRUE(initial_search) && fast_mode == FALSE) {
|
||||
# only run on first try
|
||||
|
||||
# try by removing all spaces
|
||||
@ -452,12 +452,12 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||
}
|
||||
|
||||
if (initial_search == TRUE && sum(already_known) < length(x)) {
|
||||
if (isTRUE(initial_search) && sum(already_known) < length(x)) {
|
||||
close(progress)
|
||||
}
|
||||
|
||||
# save to package env to save time for next time
|
||||
if (initial_search == TRUE) {
|
||||
if (isTRUE(initial_search)) {
|
||||
AMR_env$av_previously_coerced <- AMR_env$av_previously_coerced[which(!AMR_env$av_previously_coerced$x %in% x), , drop = FALSE]
|
||||
AMR_env$av_previously_coerced <- unique(rbind(AMR_env$av_previously_coerced,
|
||||
data.frame(
|
||||
|
2
R/data.R
2
R/data.R
@ -281,7 +281,7 @@
|
||||
#' - `original_txt`\cr Original text in the PDF file of EUCAST
|
||||
#' - `eucast_version`\cr Version number of the EUCAST Clinical Breakpoints guideline to which these dosages apply
|
||||
#' @details
|
||||
#' This data set is based on `r format_eucast_version_nr(11.0)`.
|
||||
#' This data set is based on `r format_eucast_version_nr(12.0)` and `r format_eucast_version_nr(11.0)`.
|
||||
#'
|
||||
#' ### Direct download
|
||||
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
|
||||
|
2
R/disk.R
2
R/disk.R
@ -75,7 +75,7 @@ as.disk <- function(x, na.rm = FALSE) {
|
||||
|
||||
if (!is.disk(x)) {
|
||||
x <- unlist(x)
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
x[trimws2(x) == ""] <- NA
|
||||
|
@ -165,7 +165,7 @@ eucast_rules <- function(x,
|
||||
info = interactive(),
|
||||
rules = getOption("AMR_eucastrules", default = c("breakpoints", "expert")),
|
||||
verbose = FALSE,
|
||||
version_breakpoints = 11.0,
|
||||
version_breakpoints = 12.0,
|
||||
version_expertrules = 3.3,
|
||||
ampc_cephalosporin_resistance = NA,
|
||||
only_rsi_columns = FALSE,
|
||||
@ -182,13 +182,13 @@ eucast_rules <- function(x,
|
||||
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
|
||||
|
||||
if ("custom" %in% rules & is.null(custom_rules)) {
|
||||
if ("custom" %in% rules && is.null(custom_rules)) {
|
||||
warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument",
|
||||
immediate = TRUE
|
||||
)
|
||||
rules <- rules[rules != "custom"]
|
||||
if (length(rules) == 0) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("No other rules were set, returning original data", add_fn = font_red, as_note = FALSE)
|
||||
}
|
||||
return(x)
|
||||
@ -204,11 +204,11 @@ eucast_rules <- function(x,
|
||||
expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
|
||||
|
||||
# support old setting (until AMR v1.3.0)
|
||||
if (missing(rules) & !is.null(getOption("AMR.eucast_rules", default = NULL))) {
|
||||
if (missing(rules) && !is.null(getOption("AMR.eucast_rules", default = NULL))) {
|
||||
rules <- getOption("AMR.eucast_rules")
|
||||
}
|
||||
|
||||
if (interactive() & verbose == TRUE & info == TRUE) {
|
||||
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
|
||||
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.:",
|
||||
@ -247,9 +247,9 @@ eucast_rules <- function(x,
|
||||
cat(font_subtle(" (no changes)\n"))
|
||||
} else {
|
||||
# opening
|
||||
if (n_added > 0 & n_changed == 0) {
|
||||
if (n_added > 0 && n_changed == 0) {
|
||||
cat(font_green(" ("))
|
||||
} else if (n_added == 0 & n_changed > 0) {
|
||||
} else if (n_added == 0 && n_changed > 0) {
|
||||
cat(font_blue(" ("))
|
||||
} else {
|
||||
cat(font_grey(" ("))
|
||||
@ -263,7 +263,7 @@ eucast_rules <- function(x,
|
||||
}
|
||||
}
|
||||
# separator
|
||||
if (n_added > 0 & n_changed > 0) {
|
||||
if (n_added > 0 && n_changed > 0) {
|
||||
cat(font_grey(", "))
|
||||
}
|
||||
# changes
|
||||
@ -275,9 +275,9 @@ eucast_rules <- function(x,
|
||||
}
|
||||
}
|
||||
# closing
|
||||
if (n_added > 0 & n_changed == 0) {
|
||||
if (n_added > 0 && n_changed == 0) {
|
||||
cat(font_green(")\n"))
|
||||
} else if (n_added == 0 & n_changed > 0) {
|
||||
} else if (n_added == 0 && n_changed > 0) {
|
||||
cat(font_blue(")\n"))
|
||||
} else {
|
||||
cat(font_grey(")\n"))
|
||||
@ -314,16 +314,16 @@ eucast_rules <- function(x,
|
||||
...
|
||||
)
|
||||
|
||||
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
|
||||
if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many EUCAST rules depend on it.")
|
||||
}
|
||||
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
|
||||
}
|
||||
|
||||
# data preparation ----
|
||||
if (info == TRUE & NROW(x) > 10000) {
|
||||
if (isTRUE(info) && NROW(x) > 10000) {
|
||||
message_("Preparing data...", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
|
||||
@ -430,7 +430,7 @@ eucast_rules <- function(x,
|
||||
x <- left_join_microorganisms(x, by = col_mo, suffix = c("_oldcols", ""))
|
||||
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE)
|
||||
x$genus_species <- trimws(paste(x$genus, x$species))
|
||||
if (info == TRUE & NROW(x) > 10000) {
|
||||
if (isTRUE(info) && NROW(x) > 10000) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
|
||||
@ -448,7 +448,7 @@ eucast_rules <- function(x,
|
||||
|
||||
# Other rules: enzyme inhibitors ------------------------------------------
|
||||
if (any(c("all", "other") %in% rules)) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\n")
|
||||
cat(word_wrap(
|
||||
font_bold(paste0(
|
||||
@ -487,7 +487,7 @@ eucast_rules <- function(x,
|
||||
ab_enzyme$base_name[i], " ('", font_bold(col_base), "') = R if ",
|
||||
tolower(ab_enzyme$enzyme_name[i]), " ('", font_bold(col_enzyme), "') = R"
|
||||
)
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat(word_wrap(rule_current,
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
@ -514,7 +514,7 @@ eucast_rules <- function(x,
|
||||
x <- run_changes$output
|
||||
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
|
||||
# Print number of new changes
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
# print only on last one of rules in this group
|
||||
txt_ok(n_added = n_added, n_changed = n_changed, warned = warned)
|
||||
# and reset counters
|
||||
@ -528,7 +528,7 @@ eucast_rules <- function(x,
|
||||
tolower(ab_enzyme$base_name[i]), " ('", font_bold(col_base), "') = S"
|
||||
)
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat(word_wrap(rule_current,
|
||||
width = getOption("width") - 30,
|
||||
extra_indent = 6
|
||||
@ -555,7 +555,7 @@ eucast_rules <- function(x,
|
||||
x <- run_changes$output
|
||||
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
|
||||
# Print number of new changes
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
# print only on last one of rules in this group
|
||||
txt_ok(n_added = n_added, n_changed = n_changed, warned = warned)
|
||||
# and reset counters
|
||||
@ -565,14 +565,14 @@ eucast_rules <- function(x,
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\n")
|
||||
message_("Skipping inheritance rules defined by this AMR package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R. Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
|
||||
}
|
||||
}
|
||||
|
||||
if (!any(c("all", "custom") %in% rules) & !is.null(custom_rules)) {
|
||||
if (info == TRUE) {
|
||||
if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) {
|
||||
if (isTRUE(info)) {
|
||||
message_("Skipping custom EUCAST rules, since the `rules` argument does not contain \"custom\".")
|
||||
}
|
||||
custom_rules <- NULL
|
||||
@ -626,14 +626,14 @@ eucast_rules <- function(x,
|
||||
rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group", drop = TRUE]
|
||||
rule_group_current <- eucast_rules_df[i, "reference.rule_group", drop = TRUE]
|
||||
# don't apply rules if user doesn't want to apply them
|
||||
if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) {
|
||||
if (rule_group_current %like% "breakpoint" && !any(c("all", "breakpoints") %in% rules)) {
|
||||
next
|
||||
}
|
||||
if (rule_group_current %like% "expert" & !any(c("all", "expert") %in% rules)) {
|
||||
if (rule_group_current %like% "expert" && !any(c("all", "expert") %in% rules)) {
|
||||
next
|
||||
}
|
||||
|
||||
if (isFALSE(info) | isFALSE(verbose)) {
|
||||
if (isFALSE(info) || isFALSE(verbose)) {
|
||||
rule_text <- ""
|
||||
} else {
|
||||
if (is.na(eucast_rules_df[i, "and_these_antibiotics", drop = TRUE])) {
|
||||
@ -657,9 +657,9 @@ eucast_rules <- function(x,
|
||||
rule_next <- ""
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
# Print EUCAST intro ------------------------------------------------------
|
||||
if (rule_group_current %unlike% "other" & eucast_notification_shown == FALSE) {
|
||||
if (rule_group_current %unlike% "other" && eucast_notification_shown == FALSE) {
|
||||
cat(
|
||||
paste0(
|
||||
"\n", font_grey(strrep("-", 0.95 * options()$width)), "\n",
|
||||
@ -781,7 +781,7 @@ eucast_rules <- function(x,
|
||||
)
|
||||
} else {
|
||||
source_antibiotics <- get_ab_from_namespace(source_antibiotics, cols_ab)
|
||||
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
|
||||
if (length(source_value) == 1 && length(source_antibiotics) > 1) {
|
||||
source_value <- rep(source_value, length(source_antibiotics))
|
||||
}
|
||||
if (length(source_antibiotics) == 0) {
|
||||
@ -838,7 +838,7 @@ eucast_rules <- function(x,
|
||||
x <- run_changes$output
|
||||
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
|
||||
# Print number of new changes ---------------------------------------------
|
||||
if (info == TRUE & rule_next != rule_current) {
|
||||
if (isTRUE(info) && rule_next != rule_current) {
|
||||
# print only on last one of rules in this group
|
||||
txt_ok(n_added = n_added, n_changed = n_changed, warned = warned)
|
||||
# and reset counters
|
||||
@ -849,7 +849,7 @@ eucast_rules <- function(x,
|
||||
|
||||
# Apply custom rules ----
|
||||
if (!is.null(custom_rules)) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\n")
|
||||
cat(font_bold("Custom EUCAST rules, set by user"), "\n")
|
||||
}
|
||||
@ -868,7 +868,7 @@ eucast_rules <- function(x,
|
||||
format_custom_query_rule(rule$query, colours = FALSE), ": ",
|
||||
get_antibiotic_names(cols)
|
||||
)
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
# print rule
|
||||
cat(italicise_taxonomy(word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
|
||||
width = getOption("width") - 30,
|
||||
@ -904,7 +904,7 @@ eucast_rules <- function(x,
|
||||
x <- run_changes$output
|
||||
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
|
||||
# Print number of new changes ---------------------------------------------
|
||||
if (info == TRUE & rule_next != rule_current) {
|
||||
if (isTRUE(info) && rule_next != rule_current) {
|
||||
# print only on last one of rules in this group
|
||||
txt_ok(n_added = n_added, n_changed = n_changed, warned = warned)
|
||||
# and reset counters
|
||||
@ -915,7 +915,7 @@ eucast_rules <- function(x,
|
||||
}
|
||||
|
||||
# Print overview ----------------------------------------------------------
|
||||
if (info == TRUE | verbose == TRUE) {
|
||||
if (isTRUE(info) || isTRUE(verbose)) {
|
||||
verbose_info <- x.bak %pm>%
|
||||
pm_mutate(row = pm_row_number()) %pm>%
|
||||
pm_select(`.rowid`, row) %pm>%
|
||||
@ -929,8 +929,8 @@ eucast_rules <- function(x,
|
||||
rownames(verbose_info) <- NULL
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
if (verbose == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
if (isTRUE(verbose)) {
|
||||
wouldve <- "would have "
|
||||
} else {
|
||||
wouldve <- ""
|
||||
@ -1010,9 +1010,9 @@ eucast_rules <- function(x,
|
||||
|
||||
cat(paste0(font_grey(strrep("-", 0.95 * options()$width)), "\n"))
|
||||
|
||||
if (verbose == FALSE & total_n_added + total_n_changed > 0) {
|
||||
if (isFALSE(verbose) && total_n_added + total_n_changed > 0) {
|
||||
cat("\n", word_wrap("Use ", font_bold("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "")
|
||||
} else if (verbose == TRUE) {
|
||||
} else if (isTRUE(verbose)) {
|
||||
cat("\n", word_wrap("Used '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", sep = "")
|
||||
}
|
||||
}
|
||||
@ -1034,7 +1034,7 @@ eucast_rules <- function(x,
|
||||
}
|
||||
|
||||
# Return data set ---------------------------------------------------------
|
||||
if (verbose == TRUE) {
|
||||
if (isTRUE(verbose)) {
|
||||
as_original_data_class(verbose_info, old_attributes$class)
|
||||
} else {
|
||||
# x was analysed with only unique rows, so join everything together again
|
||||
@ -1072,16 +1072,16 @@ edit_rsi <- function(x,
|
||||
)
|
||||
|
||||
txt_error <- function() {
|
||||
if (info == TRUE) cat("", font_red_bg(" ERROR "), "\n\n")
|
||||
if (isTRUE(info)) cat("", font_red_bg(" ERROR "), "\n\n")
|
||||
}
|
||||
txt_warning <- function() {
|
||||
if (warned == FALSE) {
|
||||
if (info == TRUE) cat(" ", font_orange_bg(" WARNING "), sep = "")
|
||||
if (isTRUE(info)) cat(" ", font_orange_bg(" WARNING "), sep = "")
|
||||
}
|
||||
warned <<- TRUE
|
||||
}
|
||||
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
if (length(rows) > 0 && length(cols) > 0) {
|
||||
new_edits <- x
|
||||
if (any(!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
|
||||
track_changes$rsi_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi)]
|
||||
@ -1127,7 +1127,7 @@ edit_rsi <- function(x,
|
||||
)
|
||||
|
||||
track_changes$output <- new_edits
|
||||
if ((info == TRUE | verbose == TRUE) && !isTRUE(all.equal(x, track_changes$output))) {
|
||||
if ((isTRUE(info) || isTRUE(verbose)) && !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]))
|
||||
}
|
||||
@ -1173,7 +1173,7 @@ edit_rsi <- function(x,
|
||||
|
||||
#' @rdname eucast_rules
|
||||
#' @export
|
||||
eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0) {
|
||||
eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 12.0) {
|
||||
meet_criteria(ab, allow_class = c("character", "numeric", "integer", "factor"))
|
||||
meet_criteria(administration, allow_class = "character", is_in = dosage$administration[!is.na(dosage$administration)], has_length = 1)
|
||||
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
|
||||
|
@ -243,7 +243,7 @@ first_isolate <- function(x = NULL,
|
||||
if (method == "phenotype-based" && !any_col_contains_rsi) {
|
||||
method <- "episode-based"
|
||||
}
|
||||
if (info == TRUE && message_not_thrown_before("first_isolate", "method")) {
|
||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) {
|
||||
message_(paste0(
|
||||
"Determining first isolates ",
|
||||
ifelse(method %in% c("episode-based", "phenotype-based"),
|
||||
@ -353,7 +353,7 @@ first_isolate <- function(x = NULL,
|
||||
testcodes_exclude <- NULL
|
||||
}
|
||||
# remove testcodes
|
||||
if (!is.null(testcodes_exclude) && info == TRUE && message_not_thrown_before("first_isolate", "excludingtestcodes")) {
|
||||
if (!is.null(testcodes_exclude) && isTRUE(info) && message_not_thrown_before("first_isolate", "excludingtestcodes")) {
|
||||
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE
|
||||
@ -367,7 +367,7 @@ first_isolate <- function(x = NULL,
|
||||
# filter on specimen group and keyantibiotics when they are filled in
|
||||
if (!is.null(specimen_group)) {
|
||||
check_columns_existance(col_specimen, x)
|
||||
if (info == TRUE && message_not_thrown_before("first_isolate", "excludingspecimen")) {
|
||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "excludingspecimen")) {
|
||||
message_("Excluding other than specimen group '", specimen_group, "'",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE
|
||||
@ -411,7 +411,7 @@ first_isolate <- function(x = NULL,
|
||||
|
||||
# speed up - return immediately if obvious
|
||||
if (abs(row.start) == Inf || abs(row.end) == Inf) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("=> Found ", font_bold("no isolates"),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE
|
||||
@ -420,7 +420,7 @@ first_isolate <- function(x = NULL,
|
||||
return(rep(FALSE, nrow(x)))
|
||||
}
|
||||
if (row.start == row.end) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE
|
||||
@ -429,7 +429,7 @@ first_isolate <- function(x = NULL,
|
||||
return(TRUE)
|
||||
}
|
||||
if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")),
|
||||
", as all isolates were different microbial species",
|
||||
add_fn = font_black,
|
||||
@ -447,7 +447,7 @@ first_isolate <- function(x = NULL,
|
||||
|
||||
# Analysis of first isolate ----
|
||||
if (!is.null(col_keyantimicrobials)) {
|
||||
if (info == TRUE && message_not_thrown_before("first_isolate", "type")) {
|
||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) {
|
||||
if (type == "keyantimicrobials") {
|
||||
message_("Basing inclusion on key antimicrobials, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
@ -533,7 +533,7 @@ first_isolate <- function(x = NULL,
|
||||
decimal.mark <- getOption("OutDec")
|
||||
big.mark <- ifelse(decimal.mark != ",", ",", ".")
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
# print group name if used in dplyr::group_by()
|
||||
cur_group <- import_fn("cur_group", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_group)) {
|
||||
@ -558,7 +558,7 @@ first_isolate <- function(x = NULL,
|
||||
}
|
||||
|
||||
# handle empty microorganisms
|
||||
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) && info == TRUE) {
|
||||
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) && isTRUE(info)) {
|
||||
message_(
|
||||
ifelse(include_unknown == TRUE, "Included ", "Excluded "),
|
||||
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
|
||||
@ -570,7 +570,7 @@ first_isolate <- function(x = NULL,
|
||||
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
|
||||
|
||||
# exclude all NAs
|
||||
if (anyNA(x$newvar_mo) && info == TRUE) {
|
||||
if (anyNA(x$newvar_mo) && isTRUE(info)) {
|
||||
message_(
|
||||
"Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
|
||||
decimal.mark = decimal.mark, big.mark = big.mark
|
||||
@ -594,7 +594,7 @@ first_isolate <- function(x = NULL,
|
||||
x <- x[order(x$newvar_row_index), , drop = FALSE]
|
||||
rownames(x) <- NULL
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
n_found <- sum(x$newvar_first_isolate, na.rm = TRUE)
|
||||
p_found_total <- percentage(n_found / nrow(x[which(!is.na(x$newvar_mo)), , drop = FALSE]), digits = 1)
|
||||
p_found_scope <- percentage(n_found / scope.size, digits = 1)
|
||||
|
@ -77,7 +77,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
|
||||
ab_result <- unname(all_found[names(all_found) == search_string.ab])
|
||||
|
||||
if (length(ab_result) == 0) {
|
||||
if (verbose == TRUE) {
|
||||
if (isTRUE(verbose)) {
|
||||
message_("No column found as input for ", search_string,
|
||||
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
|
||||
add_fn = font_black,
|
||||
@ -86,7 +86,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
|
||||
}
|
||||
return(NULL)
|
||||
} else {
|
||||
if (verbose == TRUE) {
|
||||
if (isTRUE(verbose)) {
|
||||
message_(
|
||||
"Using column '", font_bold(ab_result), "' as input for ", search_string,
|
||||
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
|
||||
@ -147,7 +147,7 @@ get_column_abx <- function(x,
|
||||
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(sort, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_("Auto-guessing columns suitable for analysis", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
|
||||
@ -159,14 +159,14 @@ get_column_abx <- function(x,
|
||||
|
||||
if (NROW(x) > 10000) {
|
||||
# only test maximum of 10,000 values per column
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_(" (using only ", font_bold("the first 10,000 rows"), ")...",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE
|
||||
)
|
||||
}
|
||||
x <- x[1:10000, , drop = FALSE]
|
||||
} else if (info == TRUE) {
|
||||
} else if (isTRUE(info)) {
|
||||
message_("...", appendLF = FALSE, as_note = FALSE)
|
||||
}
|
||||
|
||||
@ -210,7 +210,7 @@ get_column_abx <- function(x,
|
||||
if (length(dots) > 0) {
|
||||
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
|
||||
if (anyNA(newnames)) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_(" WARNING", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
}
|
||||
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
|
||||
@ -221,7 +221,7 @@ get_column_abx <- function(x,
|
||||
}
|
||||
unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns)))
|
||||
if (length(unexisting_cols) > 0) {
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
message_(" ERROR", add_fn = list(font_red, font_bold), as_note = FALSE)
|
||||
}
|
||||
stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE),
|
||||
@ -240,7 +240,7 @@ get_column_abx <- function(x,
|
||||
}
|
||||
|
||||
if (length(out) == 0) {
|
||||
if (info == TRUE && all_okay == TRUE) {
|
||||
if (isTRUE(info) && all_okay == TRUE) {
|
||||
message_("No columns found.")
|
||||
}
|
||||
AMR_env$get_column_abx.call <- unique_call_id(entire_session = FALSE, match_fn = fn)
|
||||
@ -259,14 +259,14 @@ get_column_abx <- function(x,
|
||||
all_okay <- FALSE
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
if (all_okay == TRUE) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
} else {
|
||||
message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
}
|
||||
for (i in seq_len(length(out))) {
|
||||
if (verbose == TRUE && !names(out[i]) %in% names(duplicates)) {
|
||||
if (isTRUE(verbose) && !names(out[i]) %in% names(duplicates)) {
|
||||
message_(
|
||||
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
|
||||
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
|
||||
@ -304,7 +304,7 @@ get_column_abx <- function(x,
|
||||
}
|
||||
if (!is.null(soft_dependencies)) {
|
||||
soft_dependencies <- unique(soft_dependencies)
|
||||
if (info == TRUE && !all(soft_dependencies %in% names(out))) {
|
||||
if (isTRUE(info) && !all(soft_dependencies %in% names(out))) {
|
||||
# missing a soft dependency may lower the reliability
|
||||
missing <- soft_dependencies[!soft_dependencies %in% names(out)]
|
||||
missing_msg <- vector_and(paste0(
|
||||
|
@ -52,7 +52,7 @@ kurtosis.default <- function(x, na.rm = FALSE, excess = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(excess, allow_class = "logical", has_length = 1)
|
||||
x <- as.vector(x)
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
n <- length(x)
|
||||
|
2
R/mic.R
2
R/mic.R
@ -176,7 +176,7 @@ as.mic <- function(x, na.rm = FALSE) {
|
||||
} else {
|
||||
x <- as.character(unlist(x))
|
||||
}
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
x[trimws2(x) == ""] <- NA
|
||||
|
@ -197,7 +197,7 @@ resistance_predict <- function(x,
|
||||
if (model %in% c("binomial", "binom", "logit")) {
|
||||
model <- "binomial"
|
||||
model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\nLogistic regression model (logit) with binomial distribution")
|
||||
cat("\n------------------------------------------------------------\n")
|
||||
print(summary(model_lm))
|
||||
@ -209,7 +209,7 @@ resistance_predict <- function(x,
|
||||
} else if (model %in% c("loglin", "poisson")) {
|
||||
model <- "poisson"
|
||||
model_lm <- with(df, glm(R ~ year, family = poisson))
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\nLog-linear regression model (loglin) with poisson distribution")
|
||||
cat("\n--------------------------------------------------------------\n")
|
||||
print(summary(model_lm))
|
||||
@ -221,7 +221,7 @@ resistance_predict <- function(x,
|
||||
} else if (model %in% c("lin", "linear")) {
|
||||
model <- "linear"
|
||||
model_lm <- with(df, lm((R / (R + S)) ~ year))
|
||||
if (info == TRUE) {
|
||||
if (isTRUE(info)) {
|
||||
cat("\nLinear regression model")
|
||||
cat("\n-----------------------\n")
|
||||
print(summary(model_lm))
|
||||
|
23
R/rsi.R
23
R/rsi.R
@ -853,7 +853,7 @@ as_rsi_method <- function(method_short,
|
||||
is_intrinsic_r <- paste(mo[i], ab_param) %in% AMR_env$intrinsic_resistant
|
||||
any_is_intrinsic_resistant <- any_is_intrinsic_resistant | is_intrinsic_r
|
||||
|
||||
if (isTRUE(add_intrinsic_resistance) & is_intrinsic_r) {
|
||||
if (isTRUE(add_intrinsic_resistance) && isTRUE(is_intrinsic_r)) {
|
||||
if (guideline_coerced %unlike% "EUCAST") {
|
||||
if (message_not_thrown_before("as.rsi", "intrinsic")) {
|
||||
warning_("in `as.rsi()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
||||
@ -985,17 +985,16 @@ as_rsi_method <- function(method_short,
|
||||
data.frame(
|
||||
datetime = Sys.time(),
|
||||
index = i,
|
||||
ab_input = ab.bak[1],
|
||||
ab_considered = ab[1],
|
||||
mo_input = mo.bak[1],
|
||||
mo_considered = mo[1],
|
||||
ab_userinput = ab.bak[1],
|
||||
ab_actual = ab[1],
|
||||
mo_userinput = mo.bak[1],
|
||||
mo_actual = mo[1],
|
||||
guideline = guideline_coerced,
|
||||
ref_table = get_record[, "ref_tbl", drop = TRUE],
|
||||
method = method,
|
||||
breakpoint_S = get_record[, "breakpoint_S", drop = TRUE],
|
||||
breakpoint_R = get_record[, "breakpoint_R", drop = TRUE],
|
||||
input = as.double(x[i]),
|
||||
interpretation = new_rsi[i],
|
||||
outcome = new_rsi[i],
|
||||
breakpoint_S_R = paste0(get_record[, "breakpoint_S", drop = TRUE], "-", get_record[, "breakpoint_R", drop = TRUE]),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
@ -1045,11 +1044,11 @@ rsi_interpretation_history <- function(clean = FALSE) {
|
||||
out <- out.bak
|
||||
if (NROW(out) == 0) {
|
||||
message_("No results to return. Run `as.rsi()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.")
|
||||
return(NULL)
|
||||
return(invisible(NULL))
|
||||
}
|
||||
out$ab_considered <- as.ab(out$ab_considered)
|
||||
out$mo_considered <- as.mo(out$mo_considered)
|
||||
out$interpretation <- as.rsi(out$interpretation)
|
||||
out$ab_actual <- as.ab(out$ab_actual)
|
||||
out$mo_actual <- as.mo(out$mo_actual)
|
||||
out$outcome <- as.rsi(out$outcome)
|
||||
# keep stored for next use
|
||||
if (isTRUE(clean)) {
|
||||
AMR_env$rsi_interpretation_history <- AMR_env$rsi_interpretation_history[0, , drop = FALSE]
|
||||
|
@ -50,7 +50,7 @@ skewness <- function(x, na.rm = FALSE) {
|
||||
skewness.default <- function(x, na.rm = FALSE) {
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
x <- as.vector(x)
|
||||
if (na.rm == TRUE) {
|
||||
if (isTRUE(na.rm)) {
|
||||
x <- x[!is.na(x)]
|
||||
}
|
||||
n <- length(x)
|
||||
|
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
Reference in New Issue
Block a user