From 15c732703d20cb128984b012b61eaef24c917a19 Mon Sep 17 00:00:00 2001 From: "Matthijs S. Berends" Date: Tue, 10 Nov 2020 16:35:56 +0100 Subject: [PATCH] (v1.4.0.9015) bugfix --- DESCRIPTION | 4 +- NEWS.md | 6 +-- R/aa_helper_functions.R | 59 ++++++++++++++++++++++------- R/ab.R | 16 ++++---- R/ab_property.R | 4 +- R/age.R | 6 +-- R/atc_online.R | 2 +- R/count.R | 4 +- R/disk.R | 8 ++-- R/eucast_rules.R | 61 +++++++++++++++++------------- R/guess_ab_col.R | 24 ++++++------ R/join_microorganisms.R | 10 ++--- R/key_antibiotics.R | 16 ++++---- R/mdro.R | 4 +- R/mic.R | 8 ++-- R/mo.R | 41 ++++++++++---------- R/mo_property.R | 2 +- R/mo_source.R | 28 ++++++++++---- R/pca.R | 2 +- R/resistance_predict.R | 2 +- R/rsi.R | 16 ++++---- R/rsi_calc.R | 8 ++-- R/translate.R | 2 +- R/zzz.R | 11 ++++-- docs/404.html | 2 +- docs/LICENSE-text.html | 2 +- docs/articles/index.html | 2 +- docs/authors.html | 2 +- docs/index.html | 4 +- docs/news/index.html | 16 ++++---- docs/pkgdown.yml | 2 +- docs/reference/index.html | 2 +- docs/survey.html | 2 +- index.md | 1 - tests/testthat/test-eucast_rules.R | 6 +-- 35 files changed, 224 insertions(+), 161 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 20d4dcc8..1da3c8c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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"), diff --git a/NEWS.md b/NEWS.md index 37ef27a5..ec6de640 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,5 @@ -# AMR 1.4.0.9014 -## Last updated: 9 November 2020 +# AMR 1.4.0.9015 +## Last updated: 10 November 2020 ### 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 diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R index bfe77618..c7d8332d 100755 --- a/R/aa_helper_functions.R +++ b/R/aa_helper_functions.R @@ -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 diff --git a/R/ab.R b/R/ab.R index 488c85eb..9913632f 100755 --- a/R/ab.R +++ b/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>% diff --git a/R/ab_property.R b/R/ab_property.R index 297aa4d1..79e711ff 100644 --- a/R/ab_property.R +++ b/R/ab_property.R @@ -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]) diff --git a/R/age.R b/R/age.R index 0183e59f..392721b9 100755 --- a/R/age.R +++ b/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] diff --git a/R/atc_online.R b/R/atc_online.R index 440d15b7..de2a7be2 100644 --- a/R/atc_online.R +++ b/R/atc_online.R @@ -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 } diff --git a/R/count.R b/R/count.R index a81b306e..43fbd5cb 100755 --- a/R/count.R +++ b/R/count.R @@ -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, diff --git a/R/disk.R b/R/disk.R index 0e5964d1..ed402605 100644 --- a/R/disk.R +++ b/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), diff --git a/R/eucast_rules.R b/R/eucast_rules.R index f0a9b0dd..3dd375e9 100755 --- a/R/eucast_rules.R +++ b/R/eucast_rules.R @@ -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 . 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 . 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 } diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R index a337fef8..8d00d569 100755 --- a/R/guess_ab_col.R +++ b/R/guess_ab_col.R @@ -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) } diff --git a/R/join_microorganisms.R b/R/join_microorganisms.R index dc2cc26e..42eb0083 100755 --- a/R/join_microorganisms.R +++ b/R/join_microorganisms.R @@ -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 } diff --git a/R/key_antibiotics.R b/R/key_antibiotics.R index e08807e6..a74e1942 100755 --- a/R/key_antibiotics.R +++ b/R/key_antibiotics.R @@ -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 diff --git a/R/mdro.R b/R/mdro.R index 40842da9..37fce4c4 100755 --- a/R/mdro.R +++ b/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_ diff --git a/R/mic.R b/R/mic.R index 879900e0..a2d2e963 100755 --- a/R/mic.R +++ b/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), diff --git a/R/mo.R b/R/mo.R index 026846c3..44fac861 100755 --- a/R/mo.R +++ b/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 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 } diff --git a/R/mo_property.R b/R/mo_property.R index ca1375de..4429c311 100755 --- a/R/mo_property.R +++ b/R/mo_property.R @@ -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]) } diff --git a/R/mo_source.R b/R/mo_source.R index b337c125..10493ab7 100644 --- a/R/mo_source.R +++ b/R/mo_source.R @@ -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) } diff --git a/R/pca.R b/R/pca.R index e4642ea3..334eaaa7 100755 --- a/R/pca.R +++ b/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 diff --git a/R/resistance_predict.R b/R/resistance_predict.R index d6ba79af..39d90bfa 100755 --- a/R/resistance_predict.R +++ b/R/resistance_predict.R @@ -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) } } diff --git a/R/rsi.R b/R/rsi.R index 2a5d8803..b92540b0 100755 --- a/R/rsi.R +++ b/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)) diff --git a/R/rsi_calc.R b/R/rsi_calc.R index 230b329d..e3d60256 100755 --- a/R/rsi_calc.R +++ b/R/rsi_calc.R @@ -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 on beforehand: your_data %pm>% mutate_if(is.rsi.eligible, as.rsi)", - call. = FALSE) + warning_("Increase speed by transforming to class 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 diff --git a/R/translate.R b/R/translate.R index 655ce655..bb4f1e5d 100755 --- a/R/translate.R +++ b/R/translate.R @@ -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) { diff --git a/R/zzz.R b/R/zzz.R index ac0f57f6..8a11e4d5 100755 --- a/R/zzz.R +++ b/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")) { diff --git a/docs/404.html b/docs/404.html index a151962d..d49e45e8 100644 --- a/docs/404.html +++ b/docs/404.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015 diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index e56c6da9..bbb17b65 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015 diff --git a/docs/articles/index.html b/docs/articles/index.html index ebcd72b0..6fde1ebb 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015 diff --git a/docs/authors.html b/docs/authors.html index df3c8717..311aaae4 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015 diff --git a/docs/index.html b/docs/index.html index 52a846e8..c4eaf778 100644 --- a/docs/index.html +++ b/docs/index.html @@ -43,7 +43,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015 @@ -198,7 +198,7 @@ AMR (for R)
-

July 2020
PLEASE TAKE PART IN OUR SURVEY!
+

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. 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!
Take me to the 5-min survey!

diff --git a/docs/news/index.html b/docs/news/index.html index 495519dc..9ba52194 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015
@@ -236,13 +236,13 @@ Source: NEWS.md -
-

-AMR 1.4.0.9014 Unreleased +
+

+AMR 1.4.0.9015 Unreleased

-
+

-Last updated: 9 November 2020 +Last updated: 10 November 2020

@@ -252,7 +252,7 @@

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:

 example_isolates %>%
-  filter(is_gram_positive())
+  filter(is_gram_positive())
 #> NOTE: Using column `mo` as input for 'x'

  • Functions %not_like% and %not_like_case% as wrappers around %like% and %like_case%. 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 %like% and by pressing it again it will be replaced with %not_like%, etc.

    • @@ -273,7 +273,7 @@

    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
    diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index 353707ec..8014e2cf 100644 --- a/docs/pkgdown.yml +++ b/docs/pkgdown.yml @@ -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 diff --git a/docs/reference/index.html b/docs/reference/index.html index 4e686847..e642e04a 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015
    diff --git a/docs/survey.html b/docs/survey.html index 31c23b77..0f9bb3d9 100644 --- a/docs/survey.html +++ b/docs/survey.html @@ -81,7 +81,7 @@ AMR (for R) - 1.4.0.9014 + 1.4.0.9015
    diff --git a/index.md b/index.md index 5d8badf8..94ed66eb 100644 --- a/index.md +++ b/index.md @@ -1,6 +1,5 @@ # `AMR` (for R) -> *July 2020*
    > **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! >
    diff --git a/tests/testthat/test-eucast_rules.R b/tests/testthat/test-eucast_rules.R index c0cd7674..f661f77c 100755 --- a/tests/testthat/test-eucast_rules.R +++ b/tests/testthat/test-eucast_rules.R @@ -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)])