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

(v0.7.1.9032) eucast_rules() improvements

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-08-09 14:28:46 +02:00
parent 1ce4b72dd2
commit 6a349bf757
33 changed files with 275 additions and 192 deletions
Download Patch File Download Diff File Expand all files Collapse all files

204
R/eucast_rules.R
View File

@ -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

6
R/globals.R
View File

@ -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",

4
R/guess_ab_col.R
View File

@ -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.

4
R/mo.R
View File

@ -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(...))

31
R/mo_property.R
View File

@ -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)
}

24
R/rsi.R
View File

@ -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'))
}

4
R/whocc.R
View File

@ -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