1
0
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:
2022-11-14 15:20:39 +01:00
parent 7ca44fb756
commit f6862a139d
35 changed files with 433 additions and 128 deletions

View File

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

View File

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

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

Binary file not shown.