From 6a349bf757a4f915963389369cd6129daa42bf35 Mon Sep 17 00:00:00 2001 From: "Matthijs S. Berends" Date: Fri, 9 Aug 2019 14:28:46 +0200 Subject: [PATCH] (v0.7.1.9032) eucast_rules() improvements --- DESCRIPTION | 4 +- NEWS.md | 12 +- R/eucast_rules.R | 204 ++++++++++++++++++---------- R/globals.R | 6 + R/guess_ab_col.R | 4 +- R/mo.R | 4 +- R/mo_property.R | 31 ++--- R/rsi.R | 24 ++-- R/whocc.R | 4 +- docs/LICENSE-text.html | 2 +- docs/articles/index.html | 2 +- docs/authors.html | 6 +- docs/index.html | 4 +- docs/news/index.html | 26 ++-- docs/reference/WHOCC.html | 5 +- docs/reference/antibiotics.html | 5 +- docs/reference/as.ab.html | 5 +- docs/reference/as.rsi.html | 2 +- docs/reference/eucast_rules.html | 7 +- docs/reference/first_isolate.html | 5 +- docs/reference/guess_ab_col.html | 6 +- docs/reference/index.html | 2 +- docs/reference/key_antibiotics.html | 2 +- docs/reference/mdro.html | 4 +- docs/reference/mo_property.html | 34 +++-- index.md | 2 +- man/WHOCC.Rd | 4 +- man/antibiotics.Rd | 4 +- man/as.ab.Rd | 4 +- man/eucast_rules.Rd | 6 +- man/guess_ab_col.Rd | 4 +- man/mdro.Rd | 2 +- man/mo_property.Rd | 31 ++--- 33 files changed, 275 insertions(+), 192 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 173ee8d7..7dc38214 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 0.7.1.9031 -Date: 2019-08-08 +Version: 0.7.1.9032 +Date: 2019-08-09 Title: Antimicrobial Resistance Analysis Authors@R: c( person(role = c("aut", "cre"), diff --git a/NEWS.md b/NEWS.md index 011d851c..75a89294 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# AMR 0.7.1.9031 +# AMR 0.7.1.9032 ### Breaking * Function `freq()` has moved to a new package, [`clean`](https://github.com/msberends/clean) ([CRAN link](https://cran.r-project.org/package=clean)). Creating frequency tables is actually not the scope of this package (never was) and this function has matured a lot over the last two years. Therefore, a new package was created for data cleaning and checking and it perfectly fits the `freq()` function. The [`clean`](https://github.com/msberends/clean) package is available on CRAN and will be installed automatically when updating the `AMR` package, that now imports it. In a later stage, the `skewness()` and `kurtosis()` functions will be moved to the `clean` package too. @@ -36,8 +36,12 @@ Since this is a major change, usage of the old `also_single_tested` will throw an informative error that it has been replaced by `only_all_tested`. ### Changed -* Added more informative errors and warnings to `eucast_rules()` -* Fixed a bug in `eucast_rules()` for *Yersinia pseudotuberculosis* +* Function: `eucast_rules()` + * Fixed a bug for *Yersinia pseudotuberculosis* + * Added more informative errors and warnings + * Printed info now distinguishes between added and changes values + * Using Verbose mode (i.e. `eucast_rules(..., verbose = TRUE)`) returns more informative and readable output + * Using factors as input now adds missing factors levels when the function changes antibiotic results * Added tibble printing support for classes `rsi`, `mic`, `ab` and `mo`. When using tibbles containing antibiotic columns, values `S` will print in green, values `I` will print in yellow and values `R` will print in red: ```r (run this on your own console, as this page does not support colour printing) @@ -61,9 +65,7 @@ * Deprecated the `country` parameter of `mdro()` in favour of the already existing `guideline` parameter to support multiple guidelines within one country * The `name` of `RIF` is now Rifampicin instead of Rifampin * The `antibiotics` data set is now sorted by name -* Using verbose mode with `eucast_rules(..., verbose = TRUE)` returns more informative and readable output * Speed improvement for `guess_ab_col()` which is now 30 times faster for antibiotic abbreviations -* Using factors as input for `eucast_rules()` now adds missing factors levels when the function changes antibiotic results #### Other * Added Dr Bart Meijer, Dr Dennis Souverein and Annick Lenglet as contributors diff --git a/R/eucast_rules.R b/R/eucast_rules.R index af1e5e80..ac553d3d 100755 --- a/R/eucast_rules.R +++ b/R/eucast_rules.R @@ -29,7 +29,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016" #' @param x data with antibiotic columns, like e.g. \code{AMX} and \code{AMC} #' @param info print progress #' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")} -#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a \code{data.frame} with extensive info about which rows and columns would be effected and in which way. +#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. #' @param ... column name of an antibiotic, see section Antibiotics #' @inheritParams first_isolate #' @details @@ -41,7 +41,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016" #' @section Antibiotics: #' To define antibiotics column names, leave as it is to determine it automatically with \code{\link{guess_ab_col}} or input a text (case-insensitive), or use \code{NULL} to skip a column (e.g. \code{TIC = NULL} to skip ticarcillin). Manually defined but non-existing columns will be skipped with a warning. #' -#' The following antibiotics are used for the functions \code{\link{eucast_rules}} and \code{\link{mdro}}. These are shown in the format '\strong{antimicrobial ID}: name (\emph{ATC code})', sorted by name: +#' The following antibiotics are used for the functions \code{\link{eucast_rules}} and \code{\link{mdro}}. These are shown below in the format '\strong{antimicrobial ID}: name (\emph{ATC code})', sorted by name: #' #' \strong{AMK}: amikacin (\href{https://www.whocc.no/atc_ddd_index/?code=J01GB06}{J01GB06}), #' \strong{AMX}: amoxicillin (\href{https://www.whocc.no/atc_ddd_index/?code=J01CA04}{J01CA04}), @@ -175,9 +175,11 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016" #' # 5 Pseudomonas aeruginosa R R - - R R R #' #' +#' \donttest{ #' # do not apply EUCAST rules, but rather get a data.frame #' # with 18 rows, containing all details about the transformations: #' c <- eucast_rules(a, verbose = TRUE) +#' } eucast_rules <- function(x, col_mo = NULL, info = TRUE, @@ -186,7 +188,7 @@ eucast_rules <- function(x, ...) { if (verbose == TRUE & interactive()) { - txt <- paste0("WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form: with extensive info about which rows and columns would be effected and in which way.", + txt <- paste0("WARNING: In Verbose mode, the eucast_rules() function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way.", "\n\nThis may overwrite your existing data if you use e.g.:", "\ndata <- eucast_rules(data, verbose = TRUE)\n\nDo you want to continue?") if ("rstudioapi" %in% rownames(installed.packages())) { @@ -202,7 +204,7 @@ eucast_rules <- function(x, if (!is.data.frame(x)) { stop("`x` must be a data frame.", call. = FALSE) } - + # try to find columns based on type # -- mo if (is.null(col_mo)) { @@ -211,40 +213,59 @@ eucast_rules <- function(x, if (is.null(col_mo)) { stop("`col_mo` must be set.", call. = FALSE) } - + if (!all(rules %in% c("breakpoints", "expert", "other", "all"))) { stop("`rules` must be one or more of: 'breakpoints', 'expert', 'other', 'all'.") } - + if (is.null(col_mo)) { stop("`col_mo` must be set") } - + decimal.mark <- getOption("OutDec") big.mark <- ifelse(decimal.mark != ",", ",", ".") formatnr <- function(x) { trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark)) } - + warned <- FALSE - + txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") } txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE } - txt_ok <- function(no_of_changes) { + txt_ok <- function(no_added, no_changed) { if (warned == FALSE) { - if (no_of_changes > 0) { - if (no_of_changes == 1) { - cat(blue(" (1 value changed)\n")) - } else { - cat(blue(paste0(" (", formatnr(no_of_changes), " values changed)\n"))) - } + if (no_added + no_changed == 0) { + cat(green(" (no changes)\n")) } else { - cat(green(" (no values changed)\n")) + # opening + cat(blue(" (")) + # additions + if (no_added > 0) { + if (no_added == 1) { + cat(blue("1 value added")) + } else { + cat(blue(formatnr(no_added), "values added")) + } + } + # separator + if (no_added > 0 & no_changed > 0) { + cat(blue(", ")) + } + # changes + if (no_changed > 0) { + if (no_changed == 1) { + cat(blue("1 value changed")) + } else { + cat(blue(formatnr(no_changed), "values changed")) + } + } + # closing + cat(blue(")\n")) } warned <<- FALSE } } - + cols_ab <- get_column_abx(x = x, soft_dependencies = c("AMC", "AMK", @@ -312,7 +333,7 @@ eucast_rules <- function(x, hard_dependencies = NULL, verbose = verbose, ...) - + AMC <- cols_ab['AMC'] AMK <- cols_ab['AMK'] AMP <- cols_ab['AMP'] @@ -376,27 +397,27 @@ eucast_rules <- function(x, TOB <- cols_ab['TOB'] TZP <- cols_ab['TZP'] VAN <- cols_ab['VAN'] - + ab_missing <- function(ab) { all(ab %in% c(NULL, NA)) } - + verbose_info <- data.frame(row = integer(0), col = character(0), mo_fullname = character(0), - old = character(0), - new = character(0), + old = as.rsi(character(0)), + new = as.rsi(character(0)), rule = character(0), rule_group = character(0), rule_name = character(0), stringsAsFactors = FALSE) - + # helper function for editing the table edit_rsi <- function(to, rule, rows, cols) { cols <- unique(cols[!is.na(cols) & !is.null(cols)]) if (length(rows) > 0 & length(cols) > 0) { before_df <- x_original - + tryCatch( # insert into original table x_original[rows, cols] <<- to, @@ -420,7 +441,7 @@ eucast_rules <- function(x, ifelse(length(rows) > 10, "...", ""), ' while writing value "', to, '" to column(s) `', paste(cols, collapse = "`, `"), - "` (data class: ", paste(class(x_original), collapse = "/"), "):\n", e$message), + "`:\n", e$message), call. = FALSE) } ) @@ -428,22 +449,23 @@ eucast_rules <- function(x, tryCatch( x[rows, cols] <<- x_original[rows, cols], error = function(e) { - stop(paste0("Error in row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), + stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","), '... while writing value "', to, '" to column(s) `', paste(cols, collapse = "`, `"), - "` (data class:", paste(class(x), collapse = "/"), "):\n", e$message), call. = FALSE) + "`:\n", e$message), call. = FALSE) } ) # before_df might not be a data.frame, but a tibble or data.table instead old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,] - no_of_changes_this_run <- 0 + track_changes <- list(added = 0, + changed = 0) for (i in 1:length(cols)) { verbose_new <- data.frame(row = rows, col = cols[i], mo_fullname = x[rows, "fullname"], - old = as.character(old[, cols[i]]), - new = as.character(x[rows, cols[i]]), + old = as.rsi(as.character(old[, cols[i]]), warn = FALSE), + new = as.rsi(as.character(x[rows, cols[i]])), rule = strip_style(rule[1]), rule_group = strip_style(rule[2]), rule_name = strip_style(rule[3]), @@ -452,18 +474,21 @@ eucast_rules <- function(x, verbose_new <- verbose_new %>% filter(old != new | is.na(old)) # save changes to data set 'verbose_info' verbose_info <<- rbind(verbose_info, verbose_new) - no_of_changes_this_run <- no_of_changes_this_run + nrow(verbose_new) + # count adds and changes + track_changes$added <- track_changes$added + verbose_new %>% filter(is.na(old)) %>% nrow() + track_changes$changed <- track_changes$changed + verbose_new %>% filter(!is.na(old)) %>% nrow() } - # after the applied changes: return number of (new) changes - return(no_of_changes_this_run) + # after the applied changes: return list with counts of added and changed + return(track_changes) } # no changes were applied: return number of (new) changes: none. - return(0) + return(list(added = 0, + changed = 0)) } - + # save original table x_original <- x - + # join to microorganisms data set suppressWarnings( x <- x %>% @@ -473,13 +498,13 @@ eucast_rules <- function(x, genus_species = paste(genus, species)) %>% as.data.frame(stringsAsFactors = FALSE) ) - + if (info == TRUE) { cat(paste0( "\nRules by the ", bold("European Committee on Antimicrobial Susceptibility Testing (EUCAST)"), "\n", blue("http://eucast.org/"), "\n")) } - + # since ampicillin ^= amoxicillin, get the first from the latter (not in original EUCAST table) if (!ab_missing(AMP) & !ab_missing(AMX)) { if (verbose == TRUE) { @@ -501,7 +526,7 @@ eucast_rules <- function(x, message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it."))) AMP <- AMX } - + # antibiotic classes aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS) tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart @@ -516,7 +541,7 @@ eucast_rules <- function(x, ureidopenicillins <- c(PIP, TZP, AZL, MEZ) all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN) fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX) - + # Help function to get available antibiotic column names ------------------ get_antibiotic_columns <- function(x, df) { x <- trimws(unlist(strsplit(x, ",", fixed = TRUE))) @@ -538,11 +563,40 @@ eucast_rules <- function(x, sort() %>% paste(collapse = ", ") } - + format_antibiotic_names <- function(ab_names, ab_results) { + ab_names <- trimws(unlist(strsplit(ab_names, ","))) + ab_results <- trimws(unlist(strsplit(ab_results, ","))) + if (length(ab_results) == 1) { + if (length(ab_names) == 1) { + # like FOX S + x <- paste(ab_names, "is") + } else if (length(ab_names) == 2) { + # like PEN,FOX S + x <- paste(paste0(ab_names, collapse = " and "), "are both") + } else { + # like PEN,FOX,GEN S (although dependency on > 2 ABx does not exist at the moment) + x <- paste(paste0(ab_names, collapse = " and "), "are all") + } + return(paste0(x, " '", ab_results, "'")) + } else { + if (length(ab_names) == 2) { + # like PEN,FOX S,R + paste0(ab_names[1], " is '", ab_results[1], "' and ", + ab_names[2], " is '", ab_results[2], "'") + } else { + # like PEN,FOX,GEN S,R,R (although dependency on > 2 ABx does not exist at the moment) + paste0(ab_names[1], " is '", ab_results[1], "' and ", + ab_names[2], " is '", ab_results[2], "' and ", + ab_names[3], " is '", ab_results[3], "'") + } + } + } + eucast_rules_df <- eucast_rules_file # internal data file - no_of_changes <- 0 + no_added <- 0 + no_changed <- 0 for (i in 1:nrow(eucast_rules_df)) { - + rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"] rule_current <- eucast_rules_df[i, "reference.rule"] rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"] @@ -553,7 +607,8 @@ eucast_rules <- function(x, rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6])) } else { rule_text <- paste0("report as '", eucast_rules_df[i, 7], "' when ", - get_antibiotic_names(eucast_rules_df[i, 4]), " is '", eucast_rules_df[i, 5], "': ", + format_antibiotic_names(ab_names = get_antibiotic_names(eucast_rules_df[i, 4]), + ab_results = eucast_rules_df[i, 5]), ": ", get_antibiotic_names(eucast_rules_df[i, 6])) } if (i == 1) { @@ -564,7 +619,7 @@ eucast_rules <- function(x, rule_next <- "" rule_group_next <- "" } - + # don't apply rules if user doesn't want to apply them if (rule_group_current %like% "breakpoint" & !any(c("all", "breakpoints") %in% rules)) { next @@ -575,8 +630,8 @@ eucast_rules <- function(x, if (rule_group_current %like% "other" & !any(c("all", "other") %in% rules)) { next } - - + + if (info == TRUE) { # Print rule (group) ------------------------------------------------------ if (rule_group_current != rule_group_previous) { @@ -604,11 +659,11 @@ eucast_rules <- function(x, warned <- FALSE } } - + # Get rule from file ------------------------------------------------------ col_mo_property <- eucast_rules_df[i, 1] like_is_one_of <- eucast_rules_df[i, 2] - + # be sure to comprise all coagulase-negative/-positive Staphylococci when they are mentioned if (eucast_rules_df[i, 3] %like% "coagulase-") { suppressWarnings( @@ -633,7 +688,7 @@ eucast_rules <- function(x, } like_is_one_of <- "like" } - + if (like_is_one_of == "is") { mo_value <- paste0("^", eucast_rules_df[i, 3], "$") } else if (like_is_one_of == "one_of") { @@ -647,12 +702,12 @@ eucast_rules <- function(x, } else { stop("invalid like_is_one_of", call. = FALSE) } - + source_antibiotics <- eucast_rules_df[i, 4] source_value <- trimws(unlist(strsplit(eucast_rules_df[i, 5], ",", fixed = TRUE))) target_antibiotics <- eucast_rules_df[i, 6] target_value <- eucast_rules_df[i, 7] - + if (is.na(source_antibiotics)) { rows <- tryCatch(which(x[, col_mo_property] %like% mo_value), error = function(e) integer(0)) @@ -682,24 +737,28 @@ eucast_rules <- function(x, stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE) } } - + cols <- get_antibiotic_columns(target_antibiotics, x) - + # Apply rule on data ------------------------------------------------------ # this will return the unique number of changes - no_of_changes <- no_of_changes + edit_rsi(to = target_value, - rule = c(rule_text, rule_group_current, rule_current), - rows = rows, - cols = cols) - + run_changes <- edit_rsi(to = target_value, + rule = c(rule_text, rule_group_current, rule_current), + rows = rows, + cols = cols) + no_added <- no_added + run_changes$added + no_changed <- no_changed + run_changes$changed + # Print number of new changes --------------------------------------------- if (info == TRUE & rule_next != rule_current) { # print only on last one of rules in this group - txt_ok(no_of_changes = no_of_changes) - no_of_changes <- 0 + txt_ok(no_added = no_added, no_changed = no_changed) + # and reset counters + no_added <- 0 + no_changed <- 0 } } - + # Print overview ---------------------------------------------------------- if (info == TRUE) { if (verbose == TRUE) { @@ -707,19 +766,19 @@ eucast_rules <- function(x, } else { wouldve <- "" } - + verbose_info <- verbose_info %>% arrange(row, rule_group, rule_name, col) - + cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n")) cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'), formatnr(n_distinct(verbose_info$row)), 'out of', formatnr(nrow(x_original)), 'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n'))) - + n_added <- verbose_info %>% filter(is.na(old)) %>% nrow() n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow() - + # print added values ---- if (n_added == 0) { colour <- cat # is function @@ -734,8 +793,6 @@ eucast_rules <- function(x, if (n_added > 0) { verbose_info %>% filter(is.na(old)) %>% - # sort it well: S < I < R - mutate(new = as.rsi(new)) %>% group_by(new) %>% summarise(n = n()) %>% mutate(plural = ifelse(n > 1, "s", ""), @@ -744,7 +801,7 @@ eucast_rules <- function(x, paste(" -", ., collapse = "\n") %>% cat() } - + # print changed values ---- if (n_changed == 0) { colour <- cat # is function @@ -762,9 +819,6 @@ eucast_rules <- function(x, if (n_changed > 0) { verbose_info %>% filter(!is.na(old)) %>% - # sort it well: S < I < R - mutate(old = as.rsi(old), - new = as.rsi(new)) %>% group_by(old, new) %>% summarise(n = n()) %>% mutate(plural = ifelse(n > 1, "s", ""), @@ -775,14 +829,14 @@ eucast_rules <- function(x, cat("\n") } cat(paste0(silver(strrep("-", options()$width - 1)), "\n")) - + if (verbose == FALSE & nrow(verbose_info) > 0) { cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n")) } else if (verbose == TRUE) { cat(paste0("\nUsed 'Verbose mode' (", bold("verbose = TRUE"), "), which returns a data.frame with all specified edits.\nUse ", bold("verbose = FALSE"), " to apply the rules on your data.\n\n")) } } - + # Return data set --------------------------------------------------------- if (verbose == TRUE) { verbose_info diff --git a/R/globals.R b/R/globals.R index f9ed702e..8954948b 100755 --- a/R/globals.R +++ b/R/globals.R @@ -57,6 +57,12 @@ globalVariables(c(".", "more_than_episode_ago", "name", "new", + "newvar_date", + "newvar_genus_species", + "newvar_mo", + "newvar_patient_id", + "newvar_row_index", + "newvar_row_index_sorted", "observations", "observed", "old", diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R index 0fc662af..d2b347b4 100755 --- a/R/guess_ab_col.R +++ b/R/guess_ab_col.R @@ -23,9 +23,9 @@ #' #' This tries to find a column name in a data set based on information from the \code{\link{antibiotics}} data set. Also supports WHONET abbreviations. #' @param x a \code{data.frame} -#' @param search_string a text to search \code{x} for +#' @param search_string a text to search \code{x} for, will be checked with \code{\link{as.ab}} if this value is not a column in \code{x} #' @param verbose a logical to indicate whether additional info should be printed -#' @details You can look for an antibiotic (trade) name or abbreviation and it will search \code{x} and the \code{\link{antibiotics}} data set for any column containing a name or ATC code of that antibiotic. \strong{Longer columns names take precendence over shorter column names.} +#' @details You can look for an antibiotic (trade) name or abbreviation and it will search \code{x} and the \code{\link{antibiotics}} data set for any column containing a name or code of that antibiotic. \strong{Longer columns names take precendence over shorter column names.} #' @importFrom dplyr %>% select filter_all any_vars #' @importFrom crayon blue #' @return A column name of \code{x}, or \code{NULL} when no result is found. diff --git a/R/mo.R b/R/mo.R index 1c183c58..2f9f7405 100755 --- a/R/mo.R +++ b/R/mo.R @@ -1581,7 +1581,7 @@ mo_uncertainties <- function() { } #' @exportMethod print.mo_uncertainties -#' @importFrom crayon green yellow red white bgGreen bgYellow bgRed +#' @importFrom crayon green yellow red white black bgGreen bgYellow bgRed #' @export #' @noRd print.mo_uncertainties <- function(x, ...) { @@ -1600,7 +1600,7 @@ print.mo_uncertainties <- function(x, ...) { colour2 <- function(...) bgGreen(white(...)) } else if (x[i, "uncertainty"] == 2) { colour1 <- yellow - colour2 <- bgYellow + colour2 <- function(...) bgYellow(black(...)) } else { colour1 <- red colour2 <- function(...) bgRed(white(...)) diff --git a/R/mo_property.R b/R/mo_property.R index dc4807e3..0ef59ed4 100755 --- a/R/mo_property.R +++ b/R/mo_property.R @@ -21,7 +21,7 @@ #' Property of a microorganism #' -#' Use these functions to return a specific property of a microorganism from the \code{\link{microorganisms}} data set. All input values will be evaluated internally with \code{\link{as.mo}}. +#' Use these functions to return a specific property of a microorganism. All input values will be evaluated internally with \code{\link{as.mo}}, which makes it possible for input of these functions to use microbial abbreviations, codes and names. See Examples. #' @param x any (vector of) text that can be coerced to a valid microorganism code with \code{\link{as.mo}} #' @param property one of the column names of the \code{\link{microorganisms}} data set or \code{"shortname"} #' @param language language of the returned text, defaults to system language (see \code{\link{get_locale}}) and can also be set with \code{\link{getOption}("AMR_locale")}. Use \code{language = NULL} or \code{language = ""} to prevent translation. @@ -53,7 +53,7 @@ #' @seealso \code{\link{microorganisms}} #' @inheritSection AMR Read more on our website! #' @examples -#' ## taxonomic tree +#' # taxonomic tree ----------------------------------------------------------- #' mo_kingdom("E. coli") # "Bacteria" #' mo_phylum("E. coli") # "Proteobacteria" #' mo_class("E. coli") # "Gammaproteobacteria" @@ -63,35 +63,33 @@ #' mo_species("E. coli") # "coli" #' mo_subspecies("E. coli") # "" #' -#' ## colloquial properties +#' # colloquial properties ---------------------------------------------------- #' mo_name("E. coli") # "Escherichia coli" #' mo_fullname("E. coli") # "Escherichia coli", same as mo_name() #' mo_shortname("E. coli") # "E. coli" #' -#' ## other properties +#' # other properties --------------------------------------------------------- #' mo_gramstain("E. coli") # "Gram-negative" #' mo_type("E. coli") # "Bacteria" (equal to kingdom, but may be translated) #' mo_rank("E. coli") # "species" #' mo_url("E. coli") # get the direct url to the online database entry #' mo_synonyms("E. coli") # get previously accepted taxonomic names #' -#' ## scientific reference +#' # scientific reference ----------------------------------------------------- #' mo_ref("E. coli") # "Castellani et al., 1919" #' mo_authors("E. coli") # "Castellani et al." #' mo_year("E. coli") # 1919 #' -#' -#' # Abbreviations known in the field +#' # abbreviations known in the field ----------------------------------------- #' mo_genus("MRSA") # "Staphylococcus" #' mo_species("MRSA") # "aureus" -#' mo_shortname("MRSA") # "S. aureus" -#' mo_gramstain("MRSA") # "Gram-positive" +#' mo_shortname("VISA") # "S. aureus" +#' mo_gramstain("VISA") # "Gram-positive" #' -#' mo_genus("VISA") # "Staphylococcus" -#' mo_species("VISA") # "aureus" +#' mo_genus("EHEC") # "Escherichia" +#' mo_species("EHEC") # "coli" #' -#' -#' # Known subspecies +#' # known subspecies --------------------------------------------------------- #' mo_name("doylei") # "Campylobacter jejuni doylei" #' mo_genus("doylei") # "Campylobacter" #' mo_species("doylei") # "jejuni" @@ -100,14 +98,14 @@ #' mo_fullname("K. pneu rh") # "Klebsiella pneumoniae rhinoscleromatis" #' mo_shortname("K. pneu rh") # "K. pneumoniae" #' -#' -#' # Becker classification, see ?as.mo +#' \donttest{ +#' # Becker classification, see ?as.mo ---------------------------------------- #' mo_fullname("S. epi") # "Staphylococcus epidermidis" #' mo_fullname("S. epi", Becker = TRUE) # "Coagulase-negative Staphylococcus (CoNS)" #' mo_shortname("S. epi") # "S. epidermidis" #' mo_shortname("S. epi", Becker = TRUE) # "CoNS" #' -#' # Lancefield classification, see ?as.mo +#' # Lancefield classification, see ?as.mo ------------------------------------ #' mo_fullname("S. pyo") # "Streptococcus pyogenes" #' mo_fullname("S. pyo", Lancefield = TRUE) # "Streptococcus group A" #' mo_shortname("S. pyo") # "S. pyogenes" @@ -136,6 +134,7 @@ #' mo_taxonomy("E. coli") #' # get a list with the taxonomy, the authors and the URL to the online database #' mo_info("E. coli") +#' } mo_name <- function(x, language = get_locale(), ...) { translate_AMR(mo_validate(x = x, property = "fullname", ...), language = language, only_unknown = FALSE) } diff --git a/R/rsi.R b/R/rsi.R index 028287e7..b772db61 100755 --- a/R/rsi.R +++ b/R/rsi.R @@ -129,18 +129,20 @@ as.rsi.default <- function(x, ...) { x <- gsub('^R+$', 'R', x) x[!x %in% c('S', 'I', 'R')] <- NA na_after <- x[is.na(x) | x == ''] %>% length() - - if (na_before != na_after) { - list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% - unique() %>% - 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) + + if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning + if (na_before != na_after) { + list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>% + unique() %>% + 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) + } } - + structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE), class = c('rsi', 'ordered', 'factor')) } diff --git a/R/whocc.R b/R/whocc.R index bd103a67..b031d8c5 100755 --- a/R/whocc.R +++ b/R/whocc.R @@ -24,11 +24,13 @@ #' All antimicrobial drugs and their official names, ATC codes, ATC groups and defined daily dose (DDD) are included in this package, using the WHO Collaborating Centre for Drug Statistics Methodology. #' @section WHOCC: #' \if{html}{\figure{logo_who.png}{options: height=60px style=margin-bottom:5px} \cr} -#' This package contains \strong{all ~450 antimicrobial drugs} and their Anatomical Therapeutic Chemical (ATC) codes, ATC groups and Defined Daily Dose (DDD) from the World Health Organization Collaborating Centre for Drug Statistics Methodology (WHOCC, \url{https://www.whocc.no}) and the Pharmaceuticals Community Register of the European Commission (\url{http://ec.europa.eu/health/documents/community-register/html/atc.htm}). \strong{NOTE: The WHOCC copyright does not allow use for commercial purposes, unlike any other info from this package. See \url{https://www.whocc.no/copyright_disclaimer/}.} +#' This package contains \strong{all ~450 antimicrobial drugs} and their Anatomical Therapeutic Chemical (ATC) codes, ATC groups and Defined Daily Dose (DDD) from the World Health Organization Collaborating Centre for Drug Statistics Methodology (WHOCC, \url{https://www.whocc.no}) and the Pharmaceuticals Community Register of the European Commission (\url{http://ec.europa.eu/health/documents/community-register/html/atc.htm}). #' #' These have become the gold standard for international drug utilisation monitoring and research. #' #' The WHOCC is located in Oslo at the Norwegian Institute of Public Health and funded by the Norwegian government. The European Commission is the executive of the European Union and promotes its general interest. +#' +#' \strong{NOTE: The WHOCC copyright does not allow use for commercial purposes, unlike any other info from this package. See \url{https://www.whocc.no/copyright_disclaimer/}.} #' @inheritSection AMR Read more on our website! #' @name WHOCC #' @rdname WHOCC diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index 64f51976..f48faeb2 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -78,7 +78,7 @@ AMR (for R) - 0.7.1.9031 + 0.7.1.9032 diff --git a/docs/articles/index.html b/docs/articles/index.html index 4604b553..9d070245 100644 --- a/docs/articles/index.html +++ b/docs/articles/index.html @@ -78,7 +78,7 @@ AMR (for R) - 0.7.1.9031 + 0.7.1.9032 diff --git a/docs/authors.html b/docs/authors.html index fdede158..2f345f87 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -78,7 +78,7 @@ AMR (for R) - 0.7.1.9031 + 0.7.1.9032 @@ -249,6 +249,10 @@

Erwin E. A. Hassing. Contributor.

+
  • +

    Annick Lenglet. Contributor. +

    +

  • Bart C. Meijer. Contributor.

    diff --git a/docs/index.html b/docs/index.html index fcda1106..99a91fb4 100644 --- a/docs/index.html +++ b/docs/index.html @@ -42,7 +42,7 @@ AMR (for R) - 0.7.1.9031 + 0.7.1.9032 @@ -315,7 +315,7 @@

  • It enhances existing data and adds new data from data sets included in this package.