1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:46:11 +01:00

(v1.4.0.9015) bugfix

This commit is contained in:
dr. M.S. (Matthijs) Berends 2020-11-10 16:35:56 +01:00
parent dd5a0319ef
commit 15c732703d
35 changed files with 224 additions and 161 deletions

View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.4.0.9014
Date: 2020-11-09
Version: 1.4.0.9015
Date: 2020-11-10
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),

View File

@ -1,5 +1,5 @@
# AMR 1.4.0.9014
## <small>Last updated: 9 November 2020</small>
# AMR 1.4.0.9015
## <small>Last updated: 10 November 2020</small>
### New
* Functions `is_gram_negative()` and `is_gram_positive()` as wrappers around `mo_gramstain()`. They always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria. If you have the `dplyr` package installed, they can even determine the column with microorganisms themselves inside `dplyr` functions:
@ -18,7 +18,7 @@
* Fix for using parameter `reference_df` in `as.mo()` and `mo_*()` functions that contain old microbial codes (from previous package versions)
### Other
* All messages thrown by this package now have correct line breaks
* All messages and warnings thrown by this package now break sentences on whole words
* More extensive unit tests
# AMR 1.4.0

View File

@ -267,13 +267,19 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
})
}
# this alternative to the message() function:
# this alternative wrapper to the message(), warning() and stop() functions:
# - wraps text to never break lines within words
# - ignores formatted text while wrapping
# - adds indentation dependent on the type of message (like NOTE)
# - add additional formatting functions like blue or bold text
message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue), as_note = TRUE) {
# - can add additional formatting functions like blue or bold text
word_wrap <- function(...,
add_fn = list(),
as_note = FALSE,
width = 0.95 * getOption("width"),
extra_indent = 0) {
msg <- paste0(c(...), collapse = "")
# replace new lines to add them again later
msg <- gsub("\n", "*|*", msg, fixed = TRUE)
if (isTRUE(as_note)) {
msg <- paste0("NOTE: ", gsub("note:? ?", "", msg, ignore.case = TRUE))
@ -284,10 +290,12 @@ message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue), as_note = T
# where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE,
width = 0.95 * getOption("width")),
width = width),
collapse = "\n")
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n")
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "")) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "")) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "")) != "\n")
# so these are the indices of spaces that need to be replaced
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
# put it together
@ -297,13 +305,14 @@ message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue), as_note = T
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "^NOTE: ") {
indentation <- 6
indentation <- 6 + extra_indent
} else if (msg_stripped %like% "^=> ") {
indentation <- 3
indentation <- 3 + extra_indent
} else {
indentation <- 0
indentation <- 0 + extra_indent
}
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
msg <- gsub("*|*", paste0("*|*", strrep(" ", indentation)), msg, fixed = TRUE)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
@ -313,14 +322,38 @@ message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue), as_note = T
msg <- add_fn[[i]](msg)
}
}
message(msg, appendLF = appendLF)
# place back spaces
msg <- gsub("*|*", "\n", msg, fixed = TRUE)
msg
}
message_ <- function(...,
appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) {
message(word_wrap(...,
add_fn = add_fn,
as_note = as_note),
appendLF = appendLF)
}
warning_ <- function(...,
add_fn = list(),
immediate = FALSE,
call = TRUE) {
warning(word_wrap(...,
add_fn = add_fn,
as_note = FALSE),
immediate. = immediate,
call. = call)
}
# this alternative to the stop() function:
# - adds the function name where the error was thrown
# - wraps text to never break lines within words
stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "")
msg <- word_wrap(..., add_fn = list(), as_note = FALSE)
if (!isFALSE(call)) {
if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1])
@ -374,7 +407,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
class_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"), call = FALSE)
value[!value %in% check_vector] <- NA
}
value

8
R/ab.R
View File

@ -434,17 +434,17 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
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) {
warning("These ATC codes are not (yet) in the antibiotics data set: ",
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
".",
call. = FALSE)
call = FALSE)
}
if (length(x_unknown) > 0) {
warning("These values could not be coerced to a valid antimicrobial ID: ",
warning_("These values could not be coerced to a valid antimicrobial ID: ",
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
".",
call. = FALSE)
call = FALSE)
}
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %pm>%

View File

@ -225,12 +225,12 @@ ab_url <- function(x, open = FALSE, ...) {
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(ab_atc(ab))]
if (length(NAs) > 0) {
warning("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
warning_("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
}
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_("Only the first URL will be opened, as `browseURL()` only suports one string.")
}
if (!is.na(u[1L])) {
utils::browseURL(u[1L])

View File

@ -83,10 +83,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
if (any(ages < 0, na.rm = TRUE)) {
ages[ages < 0] <- NA
warning("NAs introduced for ages below 0.")
warning_("NAs introduced for ages below 0.", call = TRUE)
}
if (any(ages > 120, na.rm = TRUE)) {
warning("Some ages are above 120.")
warning_("Some ages are above 120.", call = TRUE)
}
if (isTRUE(na.rm)) {
@ -154,7 +154,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.")
warning_("NAs introduced for ages below 0.", call = TRUE)
}
if (is.character(split_at)) {
split_at <- split_at[1L]

View File

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

View File

@ -134,7 +134,7 @@ count_R <- function(..., only_all_tested = FALSE) {
#' @rdname count
#' @export
count_IR <- function(..., only_all_tested = FALSE) {
warning("Using 'count_IR' is discouraged; use 'count_resistant()' instead to not consider \"I\" being resistant.", call. = FALSE)
warning_("Using 'count_IR' is discouraged; use 'count_resistant()' instead to not consider \"I\" being resistant.", call = FALSE)
rsi_calc(...,
ab_result = c("I", "R"),
only_all_tested = only_all_tested,
@ -162,7 +162,7 @@ count_SI <- function(..., only_all_tested = FALSE) {
#' @rdname count
#' @export
count_S <- function(..., only_all_tested = FALSE) {
warning("Using 'count_S' is discouraged; use 'count_susceptible()' instead to also consider \"I\" being susceptible.", call. = FALSE)
warning_("Using 'count_S' is discouraged; use 'count_susceptible()' instead to also consider \"I\" being susceptible.", call = FALSE)
rsi_calc(...,
ab_result = "S",
only_all_tested = only_all_tested,

View File

@ -101,10 +101,10 @@ as.disk <- function(x, na.rm = FALSE) {
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
warning_(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, call = FALSE)
}
}
structure(as.integer(x),

View File

@ -564,7 +564,9 @@ eucast_rules <- function(x,
x <- as.data.frame(x, stringsAsFactors = FALSE) # no tibbles, data.tables, etc.
rownames(x) <- NULL # will later be restored with old_attributes
# create unique row IDs - combination of the MO and all ABx columns (so they will only run once per unique combination)
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]))), function(x) {
x$`.rowid` <- sapply(as.list(as.data.frame(t(x[, c(col_mo, cols_ab), drop = FALSE]),
stringsAsFactors = FALSE)),
function(x) {
x[is.na(x)] <- "."
paste0(x, collapse = "")
})
@ -676,7 +678,12 @@ eucast_rules <- function(x,
} else {
if (info == TRUE) {
cat(font_red("\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.\nUse eucast_rules(..., rules = \"all\") to also apply those rules.\n"))
message_("\n\nSkipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R.",
as_note = FALSE,
add_fn = font_red)
message_("Use eucast_rules(..., rules = \"all\") to also apply those rules.",
as_note = FALSE,
add_fn = font_red)
}
}
@ -763,7 +770,9 @@ eucast_rules <- function(x,
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
# is new rule within group, print its name
cat(markup_italics_where_needed(rule_current))
cat(markup_italics_where_needed(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 4)))
warned <- FALSE
}
}
@ -903,12 +912,12 @@ eucast_rules <- function(x,
}
cat(paste0("\n", font_grey(strrep("-", 0.95 * options()$width)), "\n"))
cat(paste0("The rules ", paste0(wouldve, "affected "),
cat(word_wrap(paste0("The rules ", paste0(wouldve, "affected "),
font_bold(formatnr(pm_n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x.bak)),
"rows"),
", making a total of ",
font_bold(formatnr(nrow(verbose_info)), "edits\n")))
font_bold(formatnr(nrow(verbose_info)), "edits\n"))))
total_n_added <- verbose_info %pm>% pm_filter(is.na(old)) %pm>% nrow()
total_n_changed <- verbose_info %pm>% pm_filter(!is.na(old)) %pm>% nrow()
@ -960,21 +969,21 @@ eucast_rules <- function(x,
cat(paste0(font_grey(strrep("-", 0.95 * options()$width)), "\n"))
if (verbose == FALSE & total_n_added + total_n_changed > 0) {
cat(paste("\nUse", font_bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))
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) {
cat(paste0("\nUsed 'Verbose mode' (", font_bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", font_bold("verbose = FALSE"), " to apply the rules on your data.\n\n"))
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 = "")
}
}
if (length(warn_lacking_rsi_class) > 0) {
warn_lacking_rsi_class <- unique(warn_lacking_rsi_class)
warning("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
warning_("Not all columns with antimicrobial results are of class <rsi>. Transform them on beforehand, with e.g.:\n",
" ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\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)])),
")",
call. = FALSE)
call = FALSE)
}
# Return data set ---------------------------------------------------------
@ -1034,16 +1043,16 @@ edit_rsi <- function(x,
warning = function(w) {
if (w$message %like% "invalid factor level") {
xyz <- sapply(cols, function(col) {
new_edits[, col] <- factor(x = as.character(pm_pull(new_edits, col)), levels = c(to, levels(pm_pull(new_edits, col))))
# x[, col] <<- factor(x = as.character(pm_pull(x, col)), levels = c(to, levels(pm_pull(x, col))))
new_edits[, col] <<- factor(x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pm_pull(new_edits, col)))))
invisible()
})
new_edits[rows, cols] <- to
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE)
suppressWarnings(new_edits[rows, cols] <<- to)
warning_('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level. A better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call = FALSE)
txt_warning()
warned <- FALSE
} else {
warning(w$message, call. = FALSE)
warning_(w$message, call = FALSE)
txt_warning()
cat("\n") # txt_warning() does not append a "\n" on itself
}

View File

@ -167,8 +167,9 @@ get_column_abx <- function(x,
if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
if (any(is.na(newnames))) {
warning("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
call. = FALSE, immediate. = TRUE)
warning_("Invalid antibiotic reference(s): ", toString(names(dots)[is.na(newnames)]),
call = FALSE,
immediate = TRUE)
}
# turn all NULLs to NAs
dots <- unlist(lapply(dots, function(x) if (is.null(x)) NA else x))
@ -205,11 +206,12 @@ get_column_abx <- function(x,
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL), ").")
}
if (info == TRUE & names(x[i]) %in% names(duplicates)) {
warning(font_red(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
warning_(paste0("Using column `", font_bold(x[i]), "` as input for `", names(x)[i],
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
"), although it was matched for multiple antibiotics or columns.")),
call. = FALSE,
immediate. = verbose)
"), although it was matched for multiple antibiotics or columns."),
add_fn = font_red,
call = FALSE,
immediate = verbose)
}
}
@ -245,8 +247,8 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
} else {
any_txt <- c("", "are")
}
warning(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
paste(missing, collapse = ", ")),
immediate. = TRUE,
call. = FALSE)
immediate = TRUE,
call = FALSE)
}

View File

@ -83,7 +83,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
class(join) <- x_class
join
@ -114,7 +114,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
class(join) <- x_class
join
@ -145,7 +145,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
class(join) <- x_class
join
@ -176,7 +176,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
warning_("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
class(join) <- x_class
join
@ -280,7 +280,7 @@ check_groups_before_join <- function(x, fn) {
x <- pm_ungroup(x)
attr(x, "groups") <- NULL
class(x) <- class(x)[!class(x) %like% "group"]
warning("Groups are dropped, since the ", fn, "() function relies on merge() from base R if dplyr is not installed.", call. = FALSE)
warning_("Groups are dropped, since the ", fn, "() function relies on merge() from base R.", call = FALSE)
}
x
}

View File

@ -188,11 +188,11 @@ key_antibiotics <- function(x,
}
if (!all(col.list %in% colnames(x))) {
if (warnings == TRUE) {
warning("Some columns do not exist and will be ignored: ",
warning_("Some columns do not exist and will be ignored: ",
col.list.bak[!(col.list %in% colnames(x))] %pm>% toString(),
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
immediate. = TRUE,
call. = FALSE)
immediate = TRUE,
call = FALSE)
}
}
col.list
@ -227,7 +227,7 @@ key_antibiotics <- function(x,
gram_positive <- gram_positive[!is.null(gram_positive)]
gram_positive <- gram_positive[!is.na(gram_positive)]
if (length(gram_positive) < 12) {
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
warning_("Only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call = FALSE)
}
gram_negative <- c(universal,
@ -236,7 +236,7 @@ key_antibiotics <- function(x,
gram_negative <- gram_negative[!is.null(gram_negative)]
gram_negative <- gram_negative[!is.na(gram_negative)]
if (length(gram_negative) < 12) {
warning("only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call. = FALSE)
warning_("Only using ", length(gram_negative), " different antibiotics as key antibiotics for Gram-negatives. See ?key_antibiotics.", call = FALSE)
}
x <- as.data.frame(x, stringsAsFactors = FALSE)
@ -264,7 +264,7 @@ key_antibiotics <- function(x,
key_abs <- toupper(gsub("[^SIR]", ".", gsub("(NA|NULL)", ".", x$key_ab)))
if (pm_n_distinct(key_abs) == 1) {
warning("No distinct key antibiotics determined.", call. = FALSE)
warning_("No distinct key antibiotics determined.", call = FALSE)
}
key_abs

View File

@ -132,7 +132,7 @@ mdro <- function(x,
}
if (!is.null(list(...)$country)) {
warning("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call. = FALSE)
warning_("Using `country` is deprecated, use `guideline` instead. Please see ?mdro.", call = FALSE)
guideline <- list(...)$country
}
@ -1205,7 +1205,7 @@ mdro <- function(x,
# Results ----
if (guideline$code == "cmi2012") {
if (any(x$MDRO == -1, na.rm = TRUE)) {
warning("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
warning_("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_

View File

@ -125,10 +125,10 @@ as.mic <- function(x, na.rm = FALSE) {
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
warning_(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing, call. = FALSE)
list_missing, call = FALSE)
}
structure(.Data = factor(x, levels = lvls, ordered = TRUE),

33
R/mo.R
View File

@ -173,7 +173,7 @@ as.mo <- function(x,
& isFALSE(Becker)
& isFALSE(Lancefield), error = function(e) FALSE)) {
# don't look into valid MO codes, just return them
# is.mo() won't work - codes might change between package versions
# is.mo() won't work - MO codes might change between package versions
return(to_class_mo(x))
}
@ -1393,9 +1393,10 @@ exec_as.mo <- function(x,
"You can also use your own reference data, e.g.:\n",
' as.mo("mycode", reference_df = data.frame(own = "mycode", mo = "B_ESCHR_COLI"))\n',
' mo_name("mycode", reference_df = data.frame(own = "mycode", mo = "B_ESCHR_COLI"))\n')
warning(font_red(paste0("\n", msg)),
call. = FALSE,
immediate. = TRUE) # thus will always be shown, even if >= warnings
warning_(paste0("\n", msg),
add_fn = font_red,
call = FALSE,
immediate = TRUE) # thus will always be shown, even if >= warnings
}
# handling uncertainties ----
if (NROW(uncertainties) > 0 & initial_search == TRUE) {
@ -1420,13 +1421,13 @@ exec_as.mo <- function(x,
post_Becker <- character(0) # 2020-10-20 currently all are mentioned in above papers
if (any(x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property])) {
warning("Becker ", font_italic("et al."), " (2014, 2019) does not contain these species named after their publication: ",
warning_("Becker ", font_italic("et al."), " (2014, 2019) 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 = ", ")),
".",
call. = FALSE,
immediate. = TRUE)
call = FALSE,
immediate = TRUE)
}
# 'MO_CONS' and 'MO_COPS' are <mo> vectors created in R/zzz.R
@ -1903,13 +1904,14 @@ replace_old_mo_codes <- function(x, property) {
mo_new <- microorganisms.translation$mo_new[matched]
# assign on places where a match was found
x[which(!is.na(matched))] <- mo_new[which(!is.na(matched))]
n_matched <- length(matched[!is.na(matched)])
if (property != "mo") {
message_(font_blue("NOTE: The input contained old microbial codes (from previous package versions). Please update your MO codes with as.mo()."))
} else {
if (length(matched) == 1) {
message_(font_blue("NOTE: 1 old microbial code (from previous package versions) was updated to a current used code."))
if (n_matched == 1) {
message_(font_blue("NOTE: 1 old microbial code (from previous package versions) was updated to a current used MO code."))
} else {
message_(font_blue("NOTE:", length(matched), "old microbial codes (from previous package versions) were updated to current used codes."))
message_(font_blue("NOTE:", n_matched, "old microbial codes (from previous package versions) were updated to current used MO codes."))
}
}
}
@ -1940,13 +1942,14 @@ repair_reference_df <- function(reference_df) {
} else {
reference_df <- reference_df %pm>% pm_select(1, "mo")
}
# some microbial codes might be old
reference_df[, 2] <- as.mo(reference_df[, 2, drop = TRUE])
# remove factors, just keep characters
suppressWarnings(
reference_df[] <- lapply(reference_df, as.character)
)
colnames(reference_df)[1] <- "x"
reference_df[, "x"] <- as.character(reference_df[, "x", drop = TRUE])
reference_df[, "mo"] <- as.character(reference_df[, "mo", drop = TRUE])
# some microbial codes might be old
reference_df[, "mo"] <- as.mo(reference_df[, "mo", drop = TRUE])
reference_df
}

View File

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

View File

@ -239,7 +239,7 @@ get_mo_source <- function() {
mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
check_dataset_integrity()
if (deparse(substitute(x)) == "get_mo_source()") {
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}
if (identical(x, get_mo_source())) {
@ -247,21 +247,21 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
}
if (is.null(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " cannot be NULL", call. = FALSE)
stop_(refer_to_name, " cannot be NULL", call = FALSE)
} else {
return(FALSE)
}
}
if (!is.data.frame(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " must be a data.frame", call. = FALSE)
stop_(refer_to_name, " must be a data.frame", call = FALSE)
} else {
return(FALSE)
}
}
if (!"mo" %in% colnames(x)) {
if (stop_on_error == TRUE) {
stop(refer_to_name, " must contain a column 'mo'", call. = FALSE)
stop_(refer_to_name, " must contain a column 'mo'", call = FALSE)
} else {
return(FALSE)
}
@ -274,13 +274,27 @@ mo_source_isvalid <- function(x, refer_to_name = "`reference_df`", stop_on_error
} else {
plural <- ""
}
stop("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
stop_("Value", plural, " ", paste0("'", invalid[, 1, drop = TRUE], "'", collapse = ", "),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", paste0("'", invalid$mo, "'", collapse = ", "),
call. = FALSE)
call = FALSE)
} else {
return(FALSE)
}
}
TRUE
if (colnames(x)[1] != "mo" & nrow(x) > length(unique(x[, 1, drop = TRUE]))) {
if (stop_on_error == TRUE) {
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[1], "'", call = FALSE)
} else {
return(FALSE)
}
}
if (colnames(x)[2] != "mo" & nrow(x) > length(unique(x[, 2, drop = TRUE]))) {
if (stop_on_error == TRUE) {
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[2], "'", call = FALSE)
} else {
return(FALSE)
}
}
return(TRUE)
}

View File

@ -98,7 +98,7 @@ pca <- function(x,
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
if (any(sapply(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. Please see Examples in ?pca.")
warning_("Be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. Please see Examples in ?pca.")
}
# set column names

View File

@ -148,7 +148,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_("`I_as_R is deprecated - use I_as_S instead.", call = FALSE)
}
}

12
R/rsi.R
View File

@ -237,9 +237,9 @@ as.rsi.default <- function(x, ...) {
if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
# check if they are actually MICs or disks now that the antibiotic name is valid
if (all_valid_mics(x)) {
warning("The input seems to be MIC values. Transform them with as.mic() before running as.rsi() to interpret them.")
warning_("The input seems to be MIC values. Transform them with as.mic() before running as.rsi() to interpret them.")
} else if (all_valid_disks(x)) {
warning("The input seems to be disk diffusion values. Transform them with as.disk() before running as.rsi() to interpret them.")
warning_("The input seems to be disk diffusion values. Transform them with as.disk() before running as.rsi() to interpret them.")
}
}
@ -273,10 +273,10 @@ as.rsi.default <- function(x, ...) {
unique() %pm>%
sort()
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
warning_(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ",
list_missing, call. = FALSE)
list_missing, call = FALSE)
}
}
@ -675,14 +675,14 @@ exec_as.rsi <- function(method,
if (all(trans$uti == TRUE, na.rm = TRUE) & all(uti == FALSE)) {
message_("WARNING.", add_fn = list(font_red, font_bold), as_note = FALSE)
warning("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call. = FALSE)
warning_("Interpretation of ", font_bold(ab_name(ab, tolower = TRUE)), " for some microorganisms is only available for (uncomplicated) urinary tract infections (UTI).\n Use parameter 'uti' to set which isolates are from urine. See ?as.rsi.", call = FALSE)
warned <- TRUE
}
for (i in seq_len(length(x))) {
if (isTRUE(add_intrinsic_resistance)) {
if (!guideline_coerced %like% "EUCAST") {
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_("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call = FALSE)
} else {
get_record <- subset(intrinsic_resistant,
microorganism == mo_name(mo[i], language = NULL) & antibiotic == ab_name(ab, language = NULL))

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", call = FALSE)
return(NA)
}
@ -143,8 +143,8 @@ rsi_calc <- function(...,
}
if (print_warning == TRUE) {
warning("Increase speed by transforming to class <rsi> on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)",
call. = FALSE)
warning_("Increase speed by transforming to class <rsi> on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)",
call = FALSE)
}
if (only_count == TRUE) {
@ -155,7 +155,7 @@ rsi_calc <- function(...,
if (data_vars != "") {
data_vars <- paste(" for", data_vars)
}
warning("Introducing NA: only ", denominator, " results available", data_vars, " (`minimum` = ", minimum, ").", call. = FALSE)
warning_("Introducing NA: only ", denominator, " results available", data_vars, " (`minimum` = ", minimum, ").", call = FALSE)
fraction <- NA_real_
} else {
fraction <- numerator / denominator

View File

@ -155,7 +155,7 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
# check if text to look for is in one of the patterns
any_form_in_patterns <- tryCatch(any(from_unique %like% paste0("(", paste(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).", call = FALSE)
return(FALSE)
})
if (NROW(df_trans) == 0 | !any_form_in_patterns) {

11
R/zzz.R
View File

@ -77,10 +77,13 @@
if (!interactive() || stats::runif(1) > 0.1 || isTRUE(as.logical(getOption("AMR_silentstart", FALSE)))) {
return()
}
packageStartupMessage("Thank you for using the AMR package! ",
"If you have a minute, please anonymously fill in this short questionnaire to improve the package and its functionalities:",
"\nhttps://msberends.github.io/AMR/survey.html",
"\n[ prevent his notice with suppressPackageStartupMessages(library(AMR)) or use options(AMR_silentstart = TRUE) ]")
packageStartupMessage(word_wrap("Thank you for using the AMR package! ",
"If you have a minute, please anonymously fill in this short questionnaire to improve the package and its functionalities: ",
font_blue("https://msberends.github.io/AMR/survey.html\n"),
"[prevent his notice with ",
font_bold("suppressPackageStartupMessages(library(AMR))"),
" or use ",
font_bold("options(AMR_silentstart = TRUE)"), "]"))
}
create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -43,7 +43,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>
@ -198,7 +198,7 @@
<a href="#amr-for-r-" class="anchor"></a><code>AMR</code> (for R) <img src="./logo.png" align="right" height="120px">
</h1></div>
<blockquote>
<p><em>July 2020</em><br><span class="fa fa-clipboard-list" style="color: #128f76; font-size: 20pt; margin-right: 5px;"></span> <strong>PLEASE TAKE PART IN OUR SURVEY!</strong><br>
<p><span class="fa fa-clipboard-list" style="color: #128f76; font-size: 20pt; margin-right: 5px;"></span> <strong>PLEASE TAKE PART IN OUR SURVEY!</strong><br>
Since you are one of our users, we would like to know how you use the package and what it brought you or your organisation. <strong>If you have a minute, please <a href="./survey.html">anonymously fill in this short questionnaire</a></strong>. Your valuable input will help to improve the package and its functionalities. You can answer the open questions in either English, Spanish, French, Dutch, or German. Thank you very much in advance! <br><a class="btn btn-info btn-amr" href="./survey.html">Take me to the 5-min survey!</a></p>
</blockquote>
<div id="what-is-amr-for-r" class="section level3">

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>
@ -236,13 +236,13 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div>
<div id="amr-1409014" class="section level1">
<h1 class="page-header" data-toc-text="1.4.0.9014">
<a href="#amr-1409014" class="anchor"></a>AMR 1.4.0.9014<small> Unreleased </small>
<div id="amr-1409015" class="section level1">
<h1 class="page-header" data-toc-text="1.4.0.9015">
<a href="#amr-1409015" class="anchor"></a>AMR 1.4.0.9015<small> Unreleased </small>
</h1>
<div id="last-updated-9-november-2020" class="section level2">
<div id="last-updated-10-november-2020" class="section level2">
<h2 class="hasAnchor">
<a href="#last-updated-9-november-2020" class="anchor"></a><small>Last updated: 9 November 2020</small>
<a href="#last-updated-10-november-2020" class="anchor"></a><small>Last updated: 10 November 2020</small>
</h2>
<div id="new" class="section level3">
<h3 class="hasAnchor">
@ -252,7 +252,7 @@
<p>Functions <code><a href="../reference/mo_property.html">is_gram_negative()</a></code> and <code><a href="../reference/mo_property.html">is_gram_positive()</a></code> as wrappers around <code><a href="../reference/mo_property.html">mo_gramstain()</a></code>. They always return <code>TRUE</code> or <code>FALSE</code> (except when the input is <code>NA</code> or the MO code is <code>UNKNOWN</code>), thus always return <code>FALSE</code> for species outside the taxonomic kingdom of Bacteria. If you have the <code>dplyr</code> package installed, they can even determine the column with microorganisms themselves inside <code>dplyr</code> functions:</p>
<div class="sourceCode" id="cb1"><pre class="downlit">
<span class="va">example_isolates</span> <span class="op">%&gt;%</span>
<span class="fu"><a href="https://dplyr.tidyverse.org/reference/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">is_gram_positive</a></span><span class="op">(</span><span class="op">)</span><span class="op">)</span>
<span class="fu"><a href="https://rdrr.io/r/stats/filter.html">filter</a></span><span class="op">(</span><span class="fu"><a href="../reference/mo_property.html">is_gram_positive</a></span><span class="op">(</span><span class="op">)</span><span class="op">)</span>
<span class="co">#&gt; NOTE: Using column `mo` as input for 'x'</span></pre></div>
</li>
<li><p>Functions <code><a href="../reference/like.html">%not_like%</a></code> and <code><a href="../reference/like.html">%not_like_case%</a></code> as wrappers around <code><a href="../reference/like.html">%like%</a></code> and <code><a href="../reference/like.html">%like_case%</a></code>. The RStudio addin to insert the text " %like% " as provided in this package now iterates over all like variants. So if you have defined the keyboard shortcut Ctrl/Cmd + L to this addin, it will first insert <code><a href="../reference/like.html">%like%</a></code> and by pressing it again it will be replaced with <code><a href="../reference/like.html">%not_like%</a></code>, etc.</p></li>
@ -273,7 +273,7 @@
<h3 class="hasAnchor">
<a href="#other" class="anchor"></a>Other</h3>
<ul>
<li>All messages thrown by this package now have correct line breaks</li>
<li>All messages and warnings thrown by this package now break sentences on whole words</li>
<li>More extensive unit tests</li>
</ul>
</div>

View File

@ -12,7 +12,7 @@ articles:
datasets: datasets.html
resistance_predict: resistance_predict.html
welcome_to_AMR: welcome_to_AMR.html
last_built: 2020-11-09T14:18Z
last_built: 2020-11-10T15:32Z
urls:
reference: https://msberends.github.io/AMR//reference
article: https://msberends.github.io/AMR//articles

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9014</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.4.0.9015</span>
</span>
</div>

View File

@ -1,6 +1,5 @@
# `AMR` (for R) <img src="./logo.png" align="right" height="120px" />
> *July 2020*<br>
> <span class="fa fa-clipboard-list" style="color: #128f76; font-size: 20pt; margin-right: 5px;"></span> **PLEASE TAKE PART IN OUR SURVEY!**
> Since you are one of our users, we would like to know how you use the package and what it brought you or your organisation. **If you have a minute, please [anonymously fill in this short questionnaire](./survey.html)**. Your valuable input will help to improve the package and its functionalities. You can answer the open questions in either English, Spanish, French, Dutch, or German. Thank you very much in advance!
> <br>

View File

@ -90,12 +90,12 @@ test_that("EUCAST rules work", {
"R")
# Azithromycin and Clarythromycin must be equal to Erythromycin
a <- eucast_rules(data.frame(mo = example_isolates$mo,
a <- as.rsi(eucast_rules(data.frame(mo = example_isolates$mo,
ERY = example_isolates$ERY,
AZM = as.rsi("R"),
CLR = as.rsi("R"),
CLR = factor("R"),
stringsAsFactors = FALSE),
version_expertrules = 3.1)$CLR
version_expertrules = 3.1)$CLR)
b <- example_isolates$ERY
expect_identical(a[!is.na(b)],
b[!is.na(b)])