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

(v1.8.0.9002) as.rsi() cleanup, more informative warnings

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2022-03-02 15:38:55 +01:00
parent 18e8525d10
commit 3b2b2be5f8
35 changed files with 267 additions and 320 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
R/aa_helper_functions.R
View File

@ -206,7 +206,7 @@ check_dataset_integrity <- function() {
" overwritten by your global environment and prevent", plural[2],
" the AMR package from working correctly: ",
vector_and(overwritten, quotes = "'"),
".\nPlease rename your object", plural[3], ".", call = FALSE)
".\nPlease rename your object", plural[3], ".")
}
}
# check if other packages did not overwrite our data sets
@ -492,7 +492,7 @@ message_ <- function(...,
warning_ <- function(...,
add_fn = list(),
immediate = FALSE,
call = TRUE) {
call = FALSE) {
warning(word_wrap(...,
add_fn = add_fn,
as_note = FALSE),
@ -559,7 +559,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
return_after_integrity_check <- function(value, type, check_vector) {
if (!all(value[!is.na(value)] %in% check_vector)) {
warning_(paste0("invalid ", type, ", NA generated"), call = FALSE)
warning_(paste0("invalid ", type, ", NA generated"))
value[!value %in% check_vector] <- NA
}
value

10
R/ab.R
View File

@ -455,15 +455,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0 & fast_mode == FALSE) {
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), ".",
call = FALSE)
warning_("in `as.ab()`: these ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), ".")
}
if (length(x_unknown) > 0 & fast_mode == FALSE) {
warning_("These values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), ".",
call = FALSE)
warning_("in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), ".")
}
x_result <- x_new[match(x_bak_clean, x)]

19
R/ab_property.R
View File

@ -240,8 +240,8 @@ ab_ddd <- function(x, administration = "oral", ...) {
units <- list(...)$units
if (!is.null(units) && isTRUE(units)) {
if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
warning_("Using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead. ",
"This warning will be shown once per session.", call = FALSE)
warning_("in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
"This warning will be shown once per session.")
}
ddd_prop <- paste0(ddd_prop, "_units")
} else {
@ -250,9 +250,9 @@ ab_ddd <- function(x, administration = "oral", ...) {
out <- ab_validate(x = x, property = ddd_prop)
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
warning_("DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package. ",
warning_("in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/", call = FALSE)
"www.whocc.no/ddd/list_of_ddds_combined_products/")
}
out
}
@ -265,9 +265,9 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
x <- as.ab(x, ...)
if (any(ab_name(x, language = NULL) %like% "/")) {
warning_("DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package. ",
warning_("in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/", call = FALSE)
"www.whocc.no/ddd/list_of_ddds_combined_products/")
}
ddd_prop <- paste0(administration, "_units")
@ -311,12 +311,12 @@ ab_url <- function(x, open = FALSE, ...) {
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
if (length(NAs) > 0) {
warning_("No ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
warning_("in `ab_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
}
if (open == TRUE) {
if (length(u) > 1 & !is.na(u[1L])) {
warning_("Only the first URL will be opened, as `browseURL()` only suports one string.")
warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
}
if (!is.na(u[1L])) {
utils::browseURL(u[1L])
@ -385,7 +385,8 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
},
USE.NAMES = FALSE)
if (any(x %in% c("", NA))) {
warning_("No ", property, " found for column(s): ", vector_and(vars[x %in% c("", NA)], sort = FALSE), call = FALSE)
warning_("in `set_ab_names()`: no ", property, " found for column(s): ",
vector_and(vars[x %in% c("", NA)], sort = FALSE))
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
}

5
R/ab_selectors.R
View File

@ -481,14 +481,13 @@ ab_select_exec <- function(function_name,
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
if (any(untreatable %in% names(ab_in_data))) {
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_("Some agents in `", function_name, "()` were ignored since they cannot be used for treating patients: ",
warning_("in `", function_name, "()`: some agents were ignored since they cannot be used for treating patients: ",
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
language = NULL,
tolower = TRUE),
quotes = FALSE,
sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session.",
call = FALSE)
"This warning will be shown once per session.")
}
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
}

6
R/age.R
View File

@ -95,10 +95,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
if (any(ages < 0, na.rm = TRUE)) {
ages[!is.na(ages) & ages < 0] <- NA
warning_("NAs introduced for ages below 0.", call = TRUE)
warning_("in `age()`: NAs introduced for ages below 0.")
}
if (any(ages > 120, na.rm = TRUE)) {
warning_("Some ages are above 120.", call = TRUE)
warning_("in `age()`: some ages are above 120.")
}
if (isTRUE(na.rm)) {
@ -171,7 +171,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning_("NAs introduced for ages below 0.", call = TRUE)
warning_("in `age_groups()`: NAs introduced for ages below 0.")
}
if (is.character(split_at)) {
split_at <- split_at[1L]

2
R/atc_online.R
View File

@ -175,7 +175,7 @@ atc_online_property <- function(atc_code,
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
if (length(out) == 0) {
warning_("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call = FALSE)
warning_("in `atc_online_property()`: ATC not found: ", atc_code[i], ". Please check ", atc_url, ".")
returnvalue[i] <- NA
next
}

2
R/bug_drug_combinations.R
View File

@ -184,7 +184,7 @@ format.bug_drug_combinations <- function(x,
if (inherits(x, "grouped")) {
# bug_drug_combinations() has been run on groups, so de-group here
warning_("formatting the output of `bug_drug_combinations()` does not support grouped variables, they are ignored", call = FALSE)
warning_("in `format()`: formatting the output of `bug_drug_combinations()` does not support grouped variables, they were ignored")
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
x <- data.frame(mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
ab = gsub("(.*)%%(.*)", "\\2", names(idx)),

4
R/disk.R
View File

@ -100,10 +100,10 @@ as.disk <- function(x, na.rm = FALSE) {
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
warning_("in `as.disk()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing, call = FALSE)
list_missing)
}
}
set_clean_class(as.integer(x),

16
R/eucast_rules.R
View File

@ -181,8 +181,7 @@ eucast_rules <- function(x,
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
if ("custom" %in% rules & is.null(custom_rules)) {
warning_("No custom rules were set with the `custom_rules` argument",
call = FALSE,
warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument",
immediate = TRUE)
rules <- rules[rules != "custom"]
if (length(rules) == 0) {
@ -915,13 +914,12 @@ eucast_rules <- function(x,
# take order from original data set
warn_lacking_rsi_class <- warn_lacking_rsi_class[order(colnames(x.bak))]
warn_lacking_rsi_class <- warn_lacking_rsi_class[!is.na(warn_lacking_rsi_class)]
warning_("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
warning_("in `eucast_rules()`: not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
warn_lacking_rsi_class,
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])), ")\n",
" - ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE)
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))")
}
# Return data set ---------------------------------------------------------
@ -986,14 +984,14 @@ edit_rsi <- function(x,
TRUE
})
suppressWarnings(new_edits[rows, cols] <<- to)
warning_("Value \"", to, "\" added to the factor levels of column", ifelse(length(cols) == 1, "", "s"),
warning_("in `eucast_rules()`: value \"", to, "\" added to the factor levels of column",
ifelse(length(cols) == 1, "", "s"),
" ", vector_and(cols, quotes = "`", sort = FALSE),
" because this value was not an existing factor level.",
call = FALSE)
" because this value was not an existing factor level.")
txt_warning()
warned <- FALSE
} else {
warning_(w$message, call = FALSE)
warning_("in `eucast_rules()`: ", w$message)
txt_warning()
}
},

4
R/guess_ab_col.R
View File

@ -267,7 +267,6 @@ get_column_abx <- function(x,
", as it is already set for ",
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"),
add_fn = font_red,
call = FALSE,
immediate = verbose)
}
}
@ -338,6 +337,5 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
}
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
vector_and(missing, quotes = FALSE)),
immediate = TRUE,
call = FALSE)
immediate = TRUE)
}

2
R/join_microorganisms.R
View File

@ -170,7 +170,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
}
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
warning_("The newly joined data set contains ", nrow(joined) - nrow(x), " rows more than the number of rows of `x`.", call = FALSE)
warning_("in `", type, "_join()`: the newly joined data set contains ", nrow(joined) - nrow(x), " rows more than the number of rows of `x`.")
}
joined

10
R/key_antimicrobials.R
View File

@ -150,7 +150,7 @@ key_antimicrobials <- function(x = NULL,
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
}
if (is.null(col_mo)) {
warning_("No column found for `col_mo`, ignoring antibiotics set in `gram_negative` and `gram_positive`, and antimycotics set in `antifungal`", call = FALSE)
warning_("in `key_antimicrobials()`: no column found for `col_mo`, ignoring antibiotics set in `gram_negative` and `gram_positive`, and antimycotics set in `antifungal`")
gramstain <- NA_character_
kingdom <- NA_character_
} else {
@ -172,11 +172,11 @@ key_antimicrobials <- function(x = NULL,
if (values_new_length < values_old_length &
any(filter, na.rm = TRUE) &
message_not_thrown_before("key_antimicrobials", name)) {
warning_(ifelse(values_new_length == 0,
warning_("in `key_antimicrobials()`: ",
ifelse(values_new_length == 0,
"No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")),
"as key antimicrobials for ", name, "s. See ?key_antimicrobials.",
call = FALSE)
"as key antimicrobials for ", name, "s. See ?key_antimicrobials.")
}
generate_antimcrobials_string(x[which(filter), c(universal, values), drop = FALSE])
@ -217,7 +217,7 @@ key_antimicrobials <- function(x = NULL,
cols = cols)
if (length(unique(key_ab)) == 1) {
warning_("No distinct key antibiotics determined.", call = FALSE)
warning_("in `key_antimicrobials()`: no distinct key antibiotics determined.")
}
key_ab

8
R/mdro.R
View File

@ -240,7 +240,7 @@ mdro <- function(x = NULL,
}
if (!is.null(list(...)$country)) {
warning_("Using `country` is deprecated, use `guideline` instead. See ?mdro.", call = FALSE)
warning_("in `mdro()`: using `country` is deprecated, use `guideline` instead. See ?mdro")
guideline <- list(...)$country
}
@ -1550,8 +1550,8 @@ mdro <- function(x = NULL,
if (guideline$code == "cmi2012") {
if (any(x$MDRO == -1, na.rm = TRUE)) {
if (message_not_thrown_before("mdro", "availability")) {
warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
percentage(pct_required_classes), " (set with `pct_required_classes`)", call = FALSE)
warning_("in `mdro()`: NA introduced for isolates where the available percentage of antimicrobial classes was below ",
percentage(pct_required_classes), " (set with `pct_required_classes`)")
}
# set these -1s to NA
x[which(x$MDRO == -1), "MDRO"] <- NA_integer_
@ -1709,7 +1709,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
return("error")
})
if (identical(qry, "error")) {
warning_("in custom_mdro_guideline(): rule ", i,
warning_("in `custom_mdro_guideline()`: rule ", i,
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
pkg_env$err_msg,
call = FALSE,

4
R/mic.R
View File

@ -175,7 +175,7 @@ as.mic <- function(x, na.rm = FALSE) {
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
warning_("in `as.mic()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing, call = FALSE)
@ -358,7 +358,7 @@ sort.mic <- function(x, decreasing = FALSE, ...) {
#' @export
#' @noRd
hist.mic <- function(x, ...) {
warning_("Use `plot()` or ggplot2's `autoplot()` for optimal plotting of MIC values", call = FALSE)
warning_("in `hist()`: use `plot()` or ggplot2's `autoplot()` for optimal plotting of MIC values")
hist(log2(x))
}

47
R/mo.R
View File

@ -1489,9 +1489,8 @@ exec_as.mo <- function(x,
"You can also use your own reference data with set_mo_source() or directly, e.g.:\n",
' as.mo("mycode", reference_df = data.frame(own = "mycode", mo = "', MO_lookup$mo[match("Escherichia coli", MO_lookup$fullname)], '"))\n',
' mo_name("mycode", reference_df = data.frame(own = "mycode", mo = "', MO_lookup$mo[match("Escherichia coli", MO_lookup$fullname)], '"))\n')
warning_(paste0("\n", msg),
warning_(paste0("\nin `as.mo()`: ", msg),
add_fn = font_red,
call = FALSE,
immediate = TRUE) # thus will always be shown, even if >= warnings
}
# handling uncertainties ----
@ -1531,12 +1530,11 @@ exec_as.mo <- function(x,
# comment below code if all staphylococcal species are categorised as CoNS/CoPS
if (any(x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property])) {
if (message_not_thrown_before("as.mo", "becker")) {
warning_("Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
font_italic(paste("S.",
sort(mo_species(unique(x[x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property]]))),
collapse = ", ")),
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
call = FALSE,
immediate = TRUE)
}
}
@ -1709,8 +1707,7 @@ pillar_shaft.mo <- function(x, ...) {
col <- "The data"
}
warning_(col, " contains old MO codes (from a previous AMR package version). ",
"Please update your MO codes with `as.mo()`.",
call = FALSE)
"Please update your MO codes with `as.mo()`.")
}
# make it always fit exactly
@ -1784,8 +1781,7 @@ print.mo <- function(x, print.shortnames = FALSE, ...) {
names(x) <- x_names
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) {
warning_("Some MO codes are from a previous AMR package version. ",
"Please update these MO codes with `as.mo()`.",
call = FALSE)
"Please update the MO codes with `as.mo()`.")
}
print.default(x, quote = FALSE)
}
@ -1814,8 +1810,7 @@ summary.mo <- function(object, ...) {
as.data.frame.mo <- function(x, ...) {
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) {
warning_("The data contains old MO codes (from a previous AMR package version). ",
"Please update your MO codes with `as.mo()`.",
call = FALSE)
"Please update your MO codes with `as.mo()`.")
}
nm <- deparse1(substitute(x))
if (!"nm" %in% names(list(...))) {
@ -2119,24 +2114,22 @@ replace_old_mo_codes <- function(x, property) {
n_unique <- ""
}
if (property != "mo") {
warning_(paste0("The input contained ", n_matched,
" old MO code", ifelse(n_matched == 1, "", "s"),
" (", n_unique, "from a previous AMR package version). ",
"Please update your MO codes with `as.mo()` to increase speed."),
call = FALSE)
warning_("in `mo_", property, "()`: the input contained ", n_matched,
" old MO code", ifelse(n_matched == 1, "", "s"),
" (", n_unique, "from a previous AMR package version). ",
"Please update your MO codes with `as.mo()` to increase speed.")
} else {
warning_(paste0("The input contained ", n_matched,
" old MO code", ifelse(n_matched == 1, "", "s"),
" (", n_unique, "from a previous AMR package version). ",
n_solved, " old MO code", ifelse(n_solved == 1, "", "s"),
ifelse(n_solved == 1, " was", " were"),
ifelse(all_direct_matches, " updated ", font_bold(" guessed ")),
"to ", ifelse(n_solved == 1, "a ", ""),
"currently used MO code", ifelse(n_solved == 1, "", "s"),
ifelse(n_unsolved > 0,
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
".")),
call = FALSE)
warning_("in `as.mo()`: the input contained ", n_matched,
" old MO code", ifelse(n_matched == 1, "", "s"),
" (", n_unique, "from a previous AMR package version). ",
n_solved, " old MO code", ifelse(n_solved == 1, "", "s"),
ifelse(n_solved == 1, " was", " were"),
ifelse(all_direct_matches, " updated ", font_bold(" guessed ")),
"to ", ifelse(n_solved == 1, "a ", ""),
"currently used MO code", ifelse(n_solved == 1, "", "s"),
ifelse(n_unsolved > 0,
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
"."))
}
}
x

2
R/mo_property.R
View File

@ -684,7 +684,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
if (isTRUE(open)) {
if (length(u) > 1) {
warning_("Only the first URL will be opened, as `browseURL()` only suports one string.")
warning_("in `mo_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
}
utils::browseURL(u[1L])
}

2
R/pca.R
View File

@ -98,7 +98,7 @@ pca <- function(x,
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with [numeric] variables only. See Examples in ?pca.", call = FALSE)
warning_("in `pca()`: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in ?pca.", call = FALSE)
}
# set column names

4
R/random.R
View File

@ -106,7 +106,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (nrow(df_new) > 0) {
df <- df_new
} else {
warning_("No rows found that match mo '", mo, "', ignoring argument `mo`", call = FALSE)
warning_("in `random_", tolower(type), "()`: no rows found that match mo '", mo, "', ignoring argument `mo`")
}
}
@ -117,7 +117,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (nrow(df_new) > 0) {
df <- df_new
} else {
warning_("No rows found that match ab '", ab, "', ignoring argument `ab`", call = FALSE)
warning_("in `random_", tolower(type), "()`: no rows found that match ab '", ab, "', ignoring argument `ab`")
}
}

2
R/resistance_predict.R
View File

@ -153,7 +153,7 @@ resistance_predict <- function(x,
x <- dots[which(dots.names == "tbl")]
}
if ("I_as_R" %in% dots.names) {
warning_("`I_as_R is deprecated - use I_as_S instead.", call = FALSE)
warning_("in `resistance_predict()`: I_as_R is deprecated - use I_as_S instead.")
}
}

361
R/rsi.R
View File

@ -233,9 +233,9 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
} else if (!any(c("R", "S", "I") %in% x, na.rm = TRUE) & !all(is.na(x))) {
return(FALSE)
} else {
x <- x[!is.na(x) & !is.null(x) & x != ""]
x <- x[!is.na(x) & !is.null(x) & !x %in% c("", "-", "NULL")]
if (length(x) == 0) {
# no other values than NA or ""
# no other values than empty
cur_col <- get_current_column()
if (!is.null(cur_col)) {
ab <- suppressWarnings(as.ab(cur_col, fast_mode = TRUE, info = FALSE))
@ -257,7 +257,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
}
#' @export
# extra param: warn (never throw warning)
# extra param: warn (logical, to never throw a warning)
as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
return(x)
@ -278,22 +278,23 @@ as.rsi.default <- function(x, ...) {
x[x.bak == 2] <- "I"
x[x.bak == 3] <- "R"
}
} else if (!all(is.na(x)) && !identical(levels(x), c("R", "S", "I")) && !all(x %in% c("R", "S", "I", NA))) {
if (all(x %unlike% "(R|S|I)", na.rm = TRUE)) {
# check if they are actually MICs or disks
if (all_valid_mics(x)) {
warning_("The input seems to contain MIC values. You can transform them with `as.mic()` before running `as.rsi()` to interpret them.", call = FALSE)
warning_("in `as.rsi()`: the input seems to contain MIC values. You can transform them with `as.mic()` before running `as.rsi()` to interpret them.")
} else if (all_valid_disks(x)) {
warning_("The input seems to contain disk diffusion values. You can transform them with `as.disk()` before running `as.rsi()` to interpret them.", call = FALSE)
warning_("in `as.rsi()`: the input seems to contain disk diffusion values. You can transform them with `as.disk()` before running `as.rsi()` to interpret them.")
}
}
# trim leading and trailing spaces, new lines, etc.
x <- trimws2(as.character(unlist(x)))
x[x %in% c(NA, "", "-", "NULL")] <- NA_character_
x.bak <- x
na_before <- length(x[is.na(x) | x == ""])
na_before <- length(x[is.na(x)])
# correct for translations
trans_R <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
@ -332,19 +333,19 @@ as.rsi.default <- function(x, ...) {
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_(na_after - na_before, " results truncated (",
warning_("in `as.rsi()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ",
list_missing, call = FALSE)
}
if (any(toupper(x.bak) == "U") && message_not_thrown_before("as.rsi", "U")) {
warning_("in as.rsi(): 'U' was interpreted as 'S', following some laboratory systems", call = FALSE)
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) {
warning_("in `as.rsi()`: 'U' was interpreted as 'S', following some laboratory systems")
}
if (any(toupper(x.bak) == "D") && message_not_thrown_before("as.rsi", "D")) {
warning_("in as.rsi(): 'D' (dose-dependent) was interpreted as 'I', following some laboratory systems", call = FALSE)
if (any(toupper(x.bak[!is.na(x.bak)]) == "D") && message_not_thrown_before("as.rsi", "D")) {
warning_("in `as.rsi()`: 'D' (dose-dependent) was interpreted as 'I', following some laboratory systems")
}
if (any(toupper(x.bak) == "H") && message_not_thrown_before("as.rsi", "H")) {
warning_("in as.rsi(): 'H' was interpreted as 'I', following some laboratory systems", call = FALSE)
if (any(toupper(x.bak[!is.na(x.bak)]) == "H") && message_not_thrown_before("as.rsi", "H")) {
warning_("in `as.rsi()`: 'H' was interpreted as 'I', following some laboratory systems")
}
}
}
@ -364,89 +365,17 @@ as.rsi.mic <- function(x,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"))
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
# try to get current column, which will only be available when in across()
ab <- tryCatch(cur_column_dplyr(),
error = function(e) ab)
}
# for auto-determining mo
mo_var_found <- ""
if (is.null(mo)) {
tryCatch({
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
mo <- NULL
try({
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo <- df[, mo, drop = TRUE]
}
}, error = function(e)
stop_('No information was supplied about the microorganisms (missing argument `mo`). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
)
}
if (length(ab) == 1 && ab %like% "as.mic") {
stop_('No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.', call = FALSE)
}
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: '", font_bold(ab),
"'. Rename this column to a drug name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE)
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
mo_coerced <- rep(mo_coerced, length(x))
}
if (length(uti) == 1) {
uti <- rep(uti, length(x))
}
agent_formatted <- paste0("'", font_bold(ab), "'")
agent_name <- ab_name(ab_coerced, tolower = TRUE, language = NULL)
if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) {
agent_formatted <- paste0(agent_formatted, " (", ab_coerced, ", ", agent_name, ")")
}
message_("=> Interpreting MIC values of ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
agent_formatted,
mo_var_found,
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
font_bold(guideline_coerced),
"manually defined 'reference_data'"),
"... ",
appendLF = FALSE,
as_note = FALSE)
result <- exec_as.rsi(method = "mic",
x = x,
mo = mo_coerced,
ab = ab_coerced,
guideline = guideline_coerced,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
result
as_rsi_method(method_short = "mic",
method_long = "MIC values",
x = x,
mo = mo,
ab = ab,
guideline = guideline,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
...)
}
#' @rdname as.rsi
@ -459,88 +388,17 @@ as.rsi.disk <- function(x,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"))
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
# try to get current column, which will only be available when in across()
ab <- tryCatch(cur_column_dplyr(),
error = function(e) ab)
}
# for auto-determining mo
mo_var_found <- ""
if (is.null(mo)) {
tryCatch({
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
mo <- NULL
try({
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo <- df[, mo, drop = TRUE]
}
}, error = function(e)
stop_('No information was supplied about the microorganisms (missing argument `mo`). See ?as.rsi.\n\n',
"To transform certain columns with e.g. mutate_at(), use `data %>% mutate_at(vars(...), as.rsi, mo = .$x)`, where x is your column with microorganisms.\n",
"To tranform all disk diffusion zones in a data set, use `data %>% as.rsi()` or data %>% mutate_if(is.disk, as.rsi).", call = FALSE)
)
}
if (length(ab) == 1 && ab %like% "as.disk") {
stop_('No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.', call = FALSE)
}
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: '", font_bold(ab),
"'. Rename this column to a drug name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE)
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
mo_coerced <- rep(mo_coerced, length(x))
}
if (length(uti) == 1) {
uti <- rep(uti, length(x))
}
agent_formatted <- paste0("'", font_bold(ab), "'")
agent_name <- ab_name(ab_coerced, tolower = TRUE, language = NULL)
if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) {
agent_formatted <- paste0(agent_formatted, " (", ab_coerced, ", ", agent_name, ")")
}
message_("=> Interpreting disk zones of ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
agent_formatted,
mo_var_found,
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
font_bold(guideline_coerced),
"manually defined 'reference_data'"),
"... ",
appendLF = FALSE,
as_note = FALSE)
result <- exec_as.rsi(method = "disk",
x = x,
mo = mo_coerced,
ab = ab_coerced,
guideline = guideline_coerced,
uti = uti,
conserve_capped_values = FALSE,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
result
as_rsi_method(method_short = "disk",
method_long = "disk diffusion zones",
x = x,
mo = mo,
ab = ab,
guideline = guideline,
uti = uti,
conserve_capped_values = FALSE,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data,
...)
}
#' @rdname as.rsi
@ -560,7 +418,7 @@ as.rsi.data.frame <- function(x,
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
x.bak <- x
for (i in seq_len(ncol(x))) {
# don't keep factors, overwriting them is hard
@ -574,7 +432,7 @@ as.rsi.data.frame <- function(x,
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
}
# -- UTIs
col_uti <- uti
if (is.null(col_uti)) {
@ -615,7 +473,7 @@ as.rsi.data.frame <- function(x,
uti <- FALSE
}
}
i <- 0
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
sel <- colnames(pm_select(x, ...))
@ -625,7 +483,7 @@ as.rsi.data.frame <- function(x,
if (!is.null(col_mo)) {
sel <- sel[sel != col_mo]
}
ab_cols <- colnames(x)[vapply(FUN.VALUE = logical(1), x, function(y) {
i <<- i + 1
check <- is.mic(y) | is.disk(y)
@ -648,7 +506,7 @@ as.rsi.data.frame <- function(x,
return(FALSE)
}
})]
stop_if(length(ab_cols) == 0,
"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
@ -667,7 +525,7 @@ as.rsi.data.frame <- function(x,
}
x_mo <- as.mo(x[, col_mo, drop = TRUE])
}
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
@ -745,6 +603,106 @@ get_guideline <- function(guideline, reference_data) {
guideline_param
}
as_rsi_method <- function(method_short = "mic",
method_long = "MIC values",
x = x,
mo = NULL,
ab = deparse(substitute(x)),
guideline = "EUCAST",
uti = FALSE,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
...) {
meet_criteria(x)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"))
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(uti, allow_class = "logical", has_length = c(1, length(x)))
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
# try to get current column, which will only be available when in across()
ab <- tryCatch(cur_column_dplyr(),
error = function(e) ab)
}
# for auto-determining mo
mo_var_found <- ""
if (is.null(mo)) {
tryCatch({
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
mo <- NULL
try({
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo <- df[, mo, drop = TRUE]
}
}, error = function(e) {
mo <- NULL
})
}
if (is.null(mo)) {
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class <mo> found). See ?as.rsi.\n\n",
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.rsi, mo = x))`, where x is your column with microorganisms.\n",
"To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate(across(where(is.", method_short, "), as.rsi))`.", call = FALSE)
}
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
stop_('No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.', call = FALSE)
}
ab_coerced <- suppressWarnings(as.ab(ab))
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
message_("Returning NAs for unknown drug: '", font_bold(ab),
"'. Rename this column to a drug name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE)
return(as.rsi(rep(NA, length(x))))
}
if (length(mo_coerced) == 1) {
mo_coerced <- rep(mo_coerced, length(x))
}
if (length(uti) == 1) {
uti <- rep(uti, length(x))
}
agent_formatted <- paste0("'", font_bold(ab), "'")
agent_name <- ab_name(ab_coerced, tolower = TRUE, language = NULL)
if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) {
agent_formatted <- paste0(agent_formatted, " (", ab_coerced, ", ", agent_name, ")")
}
message_("=> Interpreting ", method_long, " of ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
agent_formatted,
mo_var_found,
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
font_bold(guideline_coerced),
"manually defined 'reference_data'"),
"... ",
appendLF = FALSE,
as_note = FALSE)
result <- exec_as.rsi(method = method_short,
x = x,
mo = mo_coerced,
ab = ab_coerced,
guideline = guideline_coerced,
uti = uti,
conserve_capped_values = conserve_capped_values,
add_intrinsic_resistance = add_intrinsic_resistance,
reference_data = reference_data) # exec_as.rsi will return message 'OK'
result
}
exec_as.rsi <- function(method,
x,
mo,
@ -767,7 +725,7 @@ exec_as.rsi <- function(method,
x <- as.disk(x) # when as.rsi.disk is called directly
}
warned <- FALSE
rise_warning <- FALSE
method_param <- toupper(method)
genera <- mo_genus(mo, language = NULL)
@ -812,13 +770,6 @@ exec_as.rsi <- function(method,
lookup_lancefield <- paste(mo_lancefield, ab)
lookup_other <- paste(mo_other, ab)
if (length(unique(paste(trans$mo, trans$ab))) == length(unique(paste(trans$mo, trans$ab, trans$uti))) &&
any(trans$uti == TRUE, na.rm = TRUE) && all(uti == FALSE)) {
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
warning_("Introducing NA: interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI). Use argument `uti` to set which isolates are from urine. See ?as.rsi.", call = FALSE)
warned <- TRUE
}
any_is_intrinsic_resistant <- FALSE
for (i in seq_len(length(x))) {
@ -828,7 +779,7 @@ exec_as.rsi <- function(method,
if (isTRUE(add_intrinsic_resistance) & is_intrinsic_r) {
if (guideline_coerced %unlike% "EUCAST") {
if (message_not_thrown_before("as.rsi", "msg2")) {
warning_("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call = FALSE)
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.")
}
} else {
new_rsi[i] <- "R"
@ -837,7 +788,7 @@ exec_as.rsi <- function(method,
}
get_record <- trans %pm>%
# no subsetting to UTI for now
# no subsetting to UTI here
subset(lookup %in% c(lookup_mo[i],
lookup_genus[i],
lookup_family[i],
@ -846,6 +797,11 @@ exec_as.rsi <- function(method,
lookup_lancefield[i],
lookup_other[i]))
if (any(get_record$uti == TRUE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "msg3", ab)) {
warning_("in `as.rsi()`: interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms. Use argument `uti` to set which isolates are from urine. See ?as.rsi.")
rise_warning <- TRUE
}
if (isTRUE(uti[i])) {
get_record <- get_record %pm>%
# be as specific as possible (i.e. prefer species over genus):
@ -856,7 +812,7 @@ exec_as.rsi <- function(method,
pm_filter(uti == FALSE) %pm>% # 'uti' is a column in rsi_translation
pm_arrange(rank_index)
}
get_record <- get_record[1L, , drop = FALSE]
if (NROW(get_record) > 0) {
@ -885,11 +841,10 @@ exec_as.rsi <- function(method,
if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) {
# found some intrinsic resistance, but was not applied
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
if (message_not_thrown_before("as.rsi", "msg3")) {
warning_("Found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.", call = FALSE)
if (message_not_thrown_before("as.rsi", "msg4")) {
warning_("in `as.rsi()`: found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.")
}
warned <- TRUE
rise_warning <- TRUE
}
new_rsi <- x_bak %pm>%
@ -898,7 +853,9 @@ exec_as.rsi <- function(method,
by = "x_mo") %pm>%
pm_pull(new_rsi)
if (warned == FALSE) {
if (isTRUE(rise_warning)) {
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
} else {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}

2
R/rsi_calc.R
View File

@ -95,7 +95,7 @@ rsi_calc <- function(...,
}
if (is.null(x)) {
warning_("argument is NULL (check if columns exist): returning NA", call = FALSE)
warning_("argument is NULL (check if columns exist): returning NA")
if (as_percent == TRUE) {
return(NA_character_)
} else {

2
R/translate.R
View File

@ -193,7 +193,7 @@ translate_AMR <- function(from,
any_form_in_patterns <- tryCatch(
any(from_unique %like% paste0("(", paste(gsub(" +\\(.*", "", df_trans$pattern), collapse = "|"), ")")),
error = function(e) {
warning_("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).", call = FALSE)
warning_("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).")
return(FALSE)
})