mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 07:51:57 +02:00
(v1.4.0.9015) bugfix
This commit is contained in:
@ -267,27 +267,35 @@ 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))
|
||||
}
|
||||
|
||||
|
||||
# we need to correct for already applied style, that adds text like "\033[31m\"
|
||||
msg_stripped <- font_stripstyle(msg)
|
||||
# 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
|
||||
@ -295,15 +303,16 @@ message_ <- function(..., appendLF = TRUE, add_fn = list(font_blue), as_note = T
|
||||
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
|
||||
msg <- paste0(msg, collapse = " ")
|
||||
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
|
||||
|
||||
16
R/ab.R
16
R/ab.R
@ -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: ",
|
||||
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call. = FALSE)
|
||||
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
|
||||
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
if (length(x_unknown) > 0) {
|
||||
warning("These values could not be coerced to a valid antimicrobial ID: ",
|
||||
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call. = FALSE)
|
||||
warning_("These values could not be coerced to a valid antimicrobial ID: ",
|
||||
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
|
||||
".",
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %pm>%
|
||||
|
||||
@ -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])
|
||||
|
||||
6
R/age.R
6
R/age.R
@ -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]
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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,
|
||||
|
||||
8
R/disk.R
8
R/disk.R
@ -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 (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid disk zones: ",
|
||||
list_missing, call = FALSE)
|
||||
}
|
||||
}
|
||||
structure(as.integer(x),
|
||||
|
||||
@ -564,10 +564,12 @@ 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[is.na(x)] <- "."
|
||||
paste0(x, collapse = "")
|
||||
})
|
||||
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 = "")
|
||||
})
|
||||
|
||||
# save original table, with the new .rowid column
|
||||
x.bak <- x
|
||||
@ -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 "),
|
||||
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")))
|
||||
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"))))
|
||||
|
||||
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",
|
||||
" ", 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)
|
||||
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)
|
||||
}
|
||||
|
||||
# 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
|
||||
}
|
||||
|
||||
@ -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],
|
||||
"` (", ab_name(names(x)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns.")),
|
||||
call. = FALSE,
|
||||
immediate. = verbose)
|
||||
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."),
|
||||
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: ",
|
||||
paste(missing, collapse = ", ")),
|
||||
immediate. = TRUE,
|
||||
call. = FALSE)
|
||||
warning_(paste0("Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
|
||||
paste(missing, collapse = ", ")),
|
||||
immediate = TRUE,
|
||||
call = FALSE)
|
||||
}
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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: ",
|
||||
col.list.bak[!(col.list %in% colnames(x))] %pm>% toString(),
|
||||
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
|
||||
immediate. = TRUE,
|
||||
call. = FALSE)
|
||||
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)
|
||||
}
|
||||
}
|
||||
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
|
||||
|
||||
4
R/mdro.R
4
R/mdro.R
@ -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_
|
||||
|
||||
8
R/mic.R
8
R/mic.R
@ -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 (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid MICs: ",
|
||||
list_missing, call = FALSE)
|
||||
}
|
||||
|
||||
structure(.Data = factor(x, levels = lvls, ordered = TRUE),
|
||||
|
||||
41
R/mo.R
41
R/mo.R
@ -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: ",
|
||||
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)
|
||||
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)
|
||||
}
|
||||
|
||||
# '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
|
||||
}
|
||||
|
||||
|
||||
@ -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])
|
||||
}
|
||||
|
||||
@ -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)
|
||||
}
|
||||
|
||||
2
R/pca.R
2
R/pca.R
@ -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
|
||||
|
||||
@ -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)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
16
R/rsi.R
16
R/rsi.R
@ -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 (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
list_missing, call. = FALSE)
|
||||
warning_(na_after - na_before, " results truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
11
R/zzz.R
@ -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")) {
|
||||
|
||||
Reference in New Issue
Block a user