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

super big huge update

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2022-09-16 23:15:23 +02:00
parent 63fe160322
commit ae9059ab99
111 changed files with 2269 additions and 89912 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
R/aa_globals.R
View File

@ -60,21 +60,22 @@ EUCAST_VERSION_EXPERT_RULES <- list(
)
)
SNOMED_VERSION <- list(
title = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS)",
current_source = "US Edition of SNOMED CT from 1 September 2020",
current_version = 12,
current_oid = "2.16.840.1.114222.4.11.1009",
value_set_name = "Microorganism",
url = "https://phinvads.cdc.gov/vads/ViewValueSet.action?oid=2.16.840.1.114222.4.11.1009"
)
CATALOGUE_OF_LIFE <- list(
year = 2019,
version = "Catalogue of Life: {year} Annual Checklist",
url_CoL = "http://www.catalogueoflife.org",
url_LPSN = "https://lpsn.dsmz.de",
yearmonth_LPSN = "5 October 2021"
TAXONOMY_VERSION <- list(
GBIF = list(
accessed_date = as.Date("2022-09-12"),
citation = "GBIF Secretariat (November 26, 2021). GBIF Backbone Taxonomy. Checklist dataset \\doi{10.15468/39omei}.",
url = "https://www.gbif.org"
),
LPSN = list(
accessed_date = as.Date("2022-09-12"),
citation = "Parte, A.C. *et al.* (2020). **List of Prokaryotic names with Standing in Nomenclature (LPSN) moves to the DSMZ.** International Journal of Systematic and Evolutionary Microbiology, 70, 5607-5612; \\doi{10.1099/ijsem.0.004332}.",
url = "https://lpsn.dsmz.de"
),
SNOMED = list(
accessed_date = as.Date("2021-07-01"),
citation = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS). US Edition of SNOMED CT from 1 September 2020. Value Set Name 'Microoganism', OID 2.16.840.1.114222.4.11.1009 (v12).",
url = "https://phinvads.cdc.gov"
)
)
globalVariables(c(
@ -117,7 +118,6 @@ globalVariables(c(
"microorganism",
"microorganisms",
"microorganisms.codes",
"microorganisms.old",
"mo",
"name",
"new",

378
R/aa_helper_functions.R
View File

@ -81,7 +81,7 @@ where <- function(fn) {
quick_case_when <- function(...) {
fs <- list(...)
lapply(fs, function(x) {
if (class(x) != "formula") {
if (!inherits(x, "formula")) {
stop("`case_when()` requires formula inputs.")
}
})
@ -208,63 +208,6 @@ addin_insert_like <- function() {
}
}
check_dataset_integrity <- function() {
# check if user overwrote our data sets in their global environment
data_in_pkg <- data(package = "AMR", envir = asNamespace("AMR"))$results[, "Item", drop = TRUE]
data_in_globalenv <- ls(envir = globalenv())
overwritten <- data_in_pkg[data_in_pkg %in% data_in_globalenv]
# exception for example_isolates
overwritten <- overwritten[overwritten %unlike% "example_isolates"]
if (length(overwritten) > 0) {
if (length(overwritten) > 1) {
plural <- c("s are", "", "s")
} else {
plural <- c(" is", "s", "")
}
if (message_not_thrown_before("check_dataset_integrity", overwritten)) {
warning_(
"The following data set", plural[1],
" overwritten by your global environment and prevent", plural[2],
" the AMR package from working correctly: ",
vector_and(overwritten, quotes = "'"),
".\nPlease rename your object", plural[3], "."
)
}
}
# check if other packages did not overwrite our data sets
valid_microorganisms <- TRUE
valid_antibiotics <- TRUE
tryCatch(
{
valid_microorganisms <- all(c(
"mo", "fullname", "kingdom", "phylum",
"class", "order", "family", "genus",
"species", "subspecies", "rank",
"species_id", "source", "ref", "prevalence"
) %in% colnames(microorganisms),
na.rm = TRUE
)
valid_antibiotics <- all(c(
"ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",
"synonyms", "oral_ddd", "oral_units",
"iv_ddd", "iv_units", "loinc"
) %in% colnames(antibiotics),
na.rm = TRUE
)
},
error = function(e) {
# package not yet loaded
require("AMR")
}
)
stop_if(
!valid_microorganisms | !valid_antibiotics,
"the data set `microorganisms` or `antibiotics` was overwritten in your environment because another package with the same object name(s) was loaded _after_ the AMR package, preventing the AMR package from working correctly. Please load the AMR package last."
)
invisible(TRUE)
}
search_type_in_df <- function(x, type, info = TRUE) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(type, allow_class = "character", has_length = 1)
@ -281,8 +224,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
# take first <mo> column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
} else if ("mo" %in% colnames_formatted &
suppressWarnings(all(x$mo %in% c(NA, microorganisms$mo)))) {
} else if ("mo" %in% colnames_formatted &&
suppressWarnings(all(x$mo %in% c(NA, AMR::microorganisms$mo)))) {
found <- "mo"
} else if (any(colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) {
found <- sort(colnames(x)[colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"])
@ -303,7 +246,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
if (any(colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)")) {
# WHONET support
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
if (!any(class(pm_pull(x, found)) %in% c("Date", "POSIXct"))) {
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
stop(font_red(paste0(
"Found column '", font_bold(found), "' to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first."
@ -357,7 +300,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
found <- found[1]
if (!is.null(found) & info == TRUE) {
if (!is.null(found) && info == TRUE) {
if (message_not_thrown_before("search_in_type", type)) {
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
@ -372,7 +315,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
is_valid_regex <- function(x) {
regex_at_all <- tryCatch(vapply(
FUN.VALUE = logical(1),
X = strsplit(x, ""),
X = strsplit(x, "", fixed = TRUE),
FUN = function(y) {
any(y %in% c(
"$", "(", ")", "*", "+", "-",
@ -390,9 +333,7 @@ is_valid_regex <- function(x) {
FUN.VALUE = logical(1),
X = x,
FUN = function(y) {
!"try-error" %in% class(try(grepl(y, "", perl = TRUE),
silent = TRUE
))
!inherits(try(grepl(y, "", perl = TRUE), silent = TRUE), "try-error")
},
USE.NAMES = FALSE
)
@ -471,7 +412,7 @@ word_wrap <- function(...,
# run word_wraps() over every line here, bind them and return again
return(paste0(vapply(
FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n")), which = "right"),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap,
add_fn = add_fn,
as_note = FALSE,
@ -497,12 +438,12 @@ word_wrap <- function(...,
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, "")) != "\n")
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\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
msg <- unlist(strsplit(msg, " "))
msg <- unlist(strsplit(msg, " ", fixed = TRUE))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
# add space around operators again
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
@ -534,6 +475,8 @@ word_wrap <- function(...,
# clean introduced whitespace between fullstops
msg <- gsub("[.] +[.]", "..", msg)
# remove extra space that was introduced (case: "Smith et al., 2022")
msg <- gsub(". ,", ".,", msg, fixed = TRUE)
msg
}
@ -608,17 +551,14 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
}
"%or%" <- function(x, y) {
if (is.null(x) | is.null(y)) {
if (is.null(x) || is.null(y)) {
if (is.null(x)) {
return(y)
} else {
return(x)
}
}
ifelse(!is.na(x),
x,
ifelse(!is.na(y), y, NA)
)
ifelse(is.na(x), y, x)
}
return_after_integrity_check <- function(value, type, check_vector) {
@ -654,9 +594,29 @@ dataset_UTF8_to_ASCII <- function(df) {
import_fn("as_tibble", "tibble")(df)
}
documentation_date <- function(d) {
paste0(trimws(format(d, "%e")), " ", month.name[as.integer(format(d, "%m"))], ", ", format(d, "%Y"))
}
format_included_data_number <- function(data) {
if (is.data.frame(data)) {
n <- nrow(data)
} else {
n <- length(unique(data))
}
if (n > 10000) {
rounder <- -3 # round on thousands
} else if (n > 1000) {
rounder <- -2 # round on hundreds
} else {
rounder <- -1 # round on tens
}
paste0("~", format(round(n, rounder), decimal.mark = ".", big.mark = ","))
}
# for eucast_rules() and mdro(), creates markdown output with URLs and names
create_eucast_ab_documentation <- function() {
x <- trimws(unique(toupper(unlist(strsplit(EUCAST_RULES_DF$then_change_these_antibiotics, ",")))))
x <- trimws(unique(toupper(unlist(strsplit(EUCAST_RULES_DF$then_change_these_antibiotics, ",", fixed = TRUE)))))
ab <- character()
for (val in x) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
@ -731,7 +691,8 @@ format_class <- function(class, plural = FALSE) {
class[class %in% c("number", "whole number")] <- "(whole) number"
}
class[class == "character"] <- "text string"
class[class %in% c("Date", "POSIXt")] <- "date"
class[class == "Date"] <- "date"
class[class %in% c("POSIXt", "POSIXct", "POSIXlt")] <- "date/time"
class[class != class.bak] <- paste0(
ifelse(plural, "", "a "),
class[class != class.bak],
@ -1010,10 +971,12 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
))
}
}
} else if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
message("NOTE: env R_RUN_TINYTEST is set to 'true', unique_call_id() not working well")
}
c(
envir = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = ""),
call = paste0(sample(c(c(0:9), letters[1:6]), size = 32, replace = TRUE), collapse = "")
envir = paste0(sample(c(0:9, letters[1:6]), size = 32, replace = TRUE), collapse = ""),
call = paste0(sample(c(0:9, letters[1:6]), size = 32, replace = TRUE), collapse = "")
)
}
@ -1100,7 +1063,10 @@ has_colour <- function() {
# set colours if console has_colour()
try_colour <- function(..., before, after, collapse = " ") {
txt <- paste0(unlist(list(...)), collapse = collapse)
if (length(c(...)) == 0) {
return(character(0))
}
txt <- paste0(c(...), collapse = collapse)
if (isTRUE(has_colour())) {
if (is.null(collapse)) {
paste0(before, txt, after, collapse = NULL)
@ -1166,26 +1132,26 @@ font_grey_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;255m", after = "\033[49m", collapse = collapse)
}
}
font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_rsi_R_bg <- function(..., collapse = " ") {
# ED553B
try_colour(..., before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_rsi_S_bg <- function(..., collapse = " ") {
# 3CAEA3
try_colour(..., before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
}
font_rsi_I_bg <- function(..., collapse = " ") {
# F6D55C
try_colour(..., before = "\033[48;5;222m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)
# this is #ed553b (picked to be colourblind-safe with other RSI colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_orange_bg <- function(..., collapse = " ") {
# this is #f6d55c (picked to be colourblind-safe with other RSI colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;222m", after = "\033[49m", collapse = collapse)
}
font_yellow_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[43m", after = "\033[49m", collapse = collapse)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;228m", after = "\033[49m", collapse = collapse)
}
font_green_bg <- function(..., collapse = " ") {
# this is #3caea3 (picked to be colourblind-safe with other RSI colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
}
font_purple_bg <- function(..., collapse = " ") {
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;89m", after = "\033[49m", collapse = collapse)
}
font_rose_bg <- function(..., collapse = " ") {
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;217m", after = "\033[49m", collapse = collapse)
}
font_na <- function(..., collapse = " ") {
font_red(..., collapse = collapse)
@ -1281,61 +1247,21 @@ as_original_data_class <- function(df, old_class = NULL) {
fn <- import_fn("as_tsibble", "tsibble")
} else if ("data.table" %in% old_class && pkg_is_available("data.table", also_load = FALSE)) {
fn <- import_fn("as.data.table", "data.table")
} else if ("tabyl" %in% old_class && pkg_is_available("janitor", also_load = FALSE)) {
fn <- import_fn("as_tabyl", "janitor")
} else {
fn <- base::as.data.frame
}
fn(df)
}
# copied from vctrs::s3_register by their permission:
# https://github.com/r-lib/vctrs/blob/05968ce8e669f73213e3e894b5f4424af4f46316/R/register-s3.R
s3_register <- function(generic, class, method = NULL) {
stopifnot(is.character(generic), length(generic) == 1)
stopifnot(is.character(class), length(class) == 1)
pieces <- strsplit(generic, "::")[[1]]
stopifnot(length(pieces) == 2)
package <- pieces[[1]]
generic <- pieces[[2]]
caller <- parent.frame()
get_method_env <- function() {
top <- topenv(caller)
if (isNamespace(top)) {
asNamespace(environmentName(top))
} else {
caller
}
}
get_method <- function(method, env) {
if (is.null(method)) {
get(paste0(generic, ".", class), envir = get_method_env())
} else {
method
}
}
method_fn <- get_method(method)
stopifnot(is.function(method_fn))
setHook(packageEvent(package, "onLoad"), function(...) {
ns <- asNamespace(package)
method_fn <- get_method(method)
registerS3method(generic, class, method_fn, envir = ns)
})
if (!isNamespaceLoaded(package)) {
return(invisible())
}
envir <- asNamespace(package)
if (exists(generic, envir)) {
registerS3method(generic, class, method_fn, envir = envir)
}
invisible()
}
# works exactly like round(), but rounds `round2(44.55, 1)` to 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 1, force_zero = TRUE) {
x <- as.double(x)
# https://stackoverflow.com/a/12688836/4575331
val <- (trunc((abs(x) * 10^digits) + 0.5) / 10^digits) * sign(x)
if (digits > 0 & force_zero == TRUE) {
if (digits > 0 && force_zero == TRUE) {
values_trans <- val[val != as.integer(val) & !is.na(val)]
val[val != as.integer(val) & !is.na(val)] <- paste0(
values_trans,
@ -1433,66 +1359,134 @@ time_track <- function(name = NULL) {
paste("(until now:", trimws(round(as.double(Sys.time()) * 1000) - pkg_env$time_start), "ms)")
}
# prevent dependency on package 'backports' ----
# these functions were not available in previous versions of R (last checked: R 4.1.0)
# see here for the full list: https://github.com/r-lib/backports
strrep <- function(x, times) {
x <- as.character(x)
if (length(x) == 0L) {
return(x)
# nolint start
# Register S3 methods ----
# copied from vctrs::s3_register by their permission:
# https://github.com/r-lib/vctrs/blob/05968ce8e669f73213e3e894b5f4424af4f46316/R/register-s3.R
s3_register <- function(generic, class, method = NULL) {
stopifnot(is.character(generic), length(generic) == 1)
stopifnot(is.character(class), length(class) == 1)
pieces <- strsplit(generic, "::")[[1]]
stopifnot(length(pieces) == 2)
package <- pieces[[1]]
generic <- pieces[[2]]
caller <- parent.frame()
get_method_env <- function() {
top <- topenv(caller)
if (isNamespace(top)) {
asNamespace(environmentName(top))
} else {
caller
}
}
unlist(.mapply(function(x, times) {
if (is.na(x) || is.na(times)) {
return(NA_character_)
get_method <- function(method, env) {
if (is.null(method)) {
get(paste0(generic, ".", class), envir = get_method_env())
} else {
method
}
if (times <= 0L) {
return("")
}
paste0(replicate(times, x), collapse = "")
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
}
trimws <- function(x, which = c("both", "left", "right"), whitespace = "[ \t\r\n]") {
which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE)
switch(which,
left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
)
}
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
}
deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
paste(deparse(expr, width.cutoff, ...), collapse = collapse)
}
file.size <- function(...) {
file.info(...)$size
}
file.mtime <- function(...) {
file.info(...)$mtime
}
str2lang <- function(s) {
stopifnot(length(s) == 1L)
ex <- parse(text = s, keep.source = FALSE)
stopifnot(length(ex) == 1L)
ex[[1L]]
}
isNamespaceLoaded <- function(pkg) {
pkg %in% loadedNamespaces()
}
lengths <- function(x, use.names = TRUE) {
vapply(x, length, FUN.VALUE = NA_integer_, USE.NAMES = use.names)
}
method_fn <- get_method(method)
stopifnot(is.function(method_fn))
setHook(packageEvent(package, "onLoad"), function(...) {
ns <- asNamespace(package)
method_fn <- get_method(method)
registerS3method(generic, class, method_fn, envir = ns)
})
if (!isNamespaceLoaded(package)) {
return(invisible())
}
envir <- asNamespace(package)
if (exists(generic, envir)) {
registerS3method(generic, class, method_fn, envir = envir)
}
invisible()
}
if (getRversion() < "3.1") {
# Support old R versions ----
# these functions were not available in previous versions of R
# see here for the full list: https://github.com/r-lib/backports
if (getRversion() < "3.1.0") {
# R-3.0 does not contain these functions, set them here to prevent installation failure
# (required for extension of the <mic> class)
cospi <- function(...) 1
sinpi <- function(...) 1
tanpi <- function(...) 1
}
dir.exists <- function(paths) {
x <- base::file.info(paths)$isdir
!is.na(x) & x
if (getRversion() < "3.2.0") {
anyNA <- function(x, recursive = FALSE) {
if (isTRUE(recursive) && (is.list(x) || is.pairlist(x))) {
return(any(rapply(x, anyNA, how = "unlist", recursive = FALSE)))
}
any(is.na(x))
}
dir.exists <- function(paths) {
x <- base::file.info(paths)$isdir
!is.na(x) & x
}
file.size <- function(...) {
file.info(...)$size
}
file.mtime <- function(...) {
file.info(...)$mtime
}
isNamespaceLoaded <- function(pkg) {
pkg %in% loadedNamespaces()
}
lengths <- function(x, use.names = TRUE) {
vapply(x, length, FUN.VALUE = NA_integer_, USE.NAMES = use.names)
}
}
if (getRversion() < "3.3.0") {
strrep <- function(x, times) {
x <- as.character(x)
if (length(x) == 0L) {
return(x)
}
unlist(.mapply(function(x, times) {
if (is.na(x) || is.na(times)) {
return(NA_character_)
}
if (times <= 0L) {
return("")
}
paste0(replicate(times, x), collapse = "")
}, list(x = x, times = times), MoreArgs = list()), use.names = FALSE)
}
trimws <- function(x, which = c("both", "left", "right"), whitespace = "[ \t\r\n]") {
which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE)
switch(which,
left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
)
}
}
if (getRversion() < "3.4.2") {
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
}
}
if (getRversion() < "3.6.0") {
str2lang <- function(s) {
stopifnot(length(s) == 1L)
ex <- parse(text = s, keep.source = FALSE)
stopifnot(length(ex) == 1L)
ex[[1L]]
}
}
if (getRversion() < "4.0.0") {
deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
paste(deparse(expr, width.cutoff, ...), collapse = collapse)
}
}
# nolint end

2
R/aa_helper_pm_functions.R
View File

@ -601,7 +601,7 @@ pm_near <- function(x, y, tol = .Machine$double.eps^0.5) {
pm_pull <- function(.data, var = -1) {
var_deparse <- pm_deparse_var(var)
col_names <- colnames(.data)
if (!(var_deparse %in% col_names) & grepl("^[[:digit:]]+L|[[:digit:]]", var_deparse)) {
if (!(var_deparse %in% col_names) && grepl("^[[:digit:]]+L|[[:digit:]]", var_deparse)) {
var <- as.integer(gsub("L", "", var_deparse))
var <- pm_if_else(var < 1L, rev(col_names)[abs(var)], col_names[var])
} else if (var_deparse %in% col_names) {

41
R/ab.R
View File

@ -91,8 +91,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
check_dataset_integrity()
if (is.ab(x)) {
return(x)
}
@ -109,7 +107,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_bak <- x
x <- toupper(x)
x_nonNA <- x[!is.na(x)]
# remove diacritics
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
@ -128,7 +125,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_unknown_ATCs <- character(0)
note_if_more_than_one_found <- function(found, index, from_text) {
if (initial_search == TRUE & isTRUE(length(from_text) > 1)) {
if (initial_search == TRUE && isTRUE(length(from_text) > 1)) {
abnames <- ab_name(from_text, tolower = TRUE, initial_search = FALSE)
if (ab_name(found[1L], language = NULL) %like% "(clavulanic acid|avibactam)") {
abnames <- abnames[!abnames %in% c("clavulanic acid", "avibactam")]
@ -165,7 +162,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[known_codes_cid] <- AB_lookup$ab[match(x[known_codes_cid], AB_lookup$cid)]
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid
if (initial_search == TRUE & sum(already_known) < length(x)) {
if (initial_search == TRUE && sum(already_known) < length(x)) {
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
on.exit(close(progress))
}
@ -175,10 +172,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
progress$tick()
}
if (is.na(x[i]) | is.null(x[i])) {
if (is.na(x[i]) || is.null(x[i])) {
next
}
if (identical(x[i], "") |
if (identical(x[i], "") ||
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
identical(tolower(x[i]), "bacteria")) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
@ -211,7 +208,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
AB_lookup$generalised_loinc,
function(s) x[i] %in% s
))
found <- antibiotics$ab[loinc_found == TRUE]
found <- AMR::antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -222,7 +219,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
AB_lookup$generalised_synonyms,
function(s) x[i] %in% s
))
found <- antibiotics$ab[synonym_found == TRUE]
found <- AMR::antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -232,9 +229,9 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
abbr_found <- unlist(lapply(
AB_lookup$generalised_abbreviations,
# require at least 2 characters for abbreviations
function(s) x[i] %in% s & nchar(x[i]) >= 2
function(s) x[i] %in% s && nchar(x[i]) >= 2
))
found <- antibiotics$ab[abbr_found == TRUE]
found <- AMR::antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -281,14 +278,14 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# try if name starts with it
found <- antibiotics[which(AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
found <- AMR::antibiotics[which(AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# try if name ends with it
found <- antibiotics[which(AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
if (nchar(x[i]) >= 4 & length(found) > 0) {
found <- AMR::antibiotics[which(AB_lookup$generalised_name %like% paste0(x_spelling, "$")), "ab", drop = TRUE]
if (nchar(x[i]) >= 4 && length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
@ -298,7 +295,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))
))
found <- antibiotics$ab[synonym_found == TRUE]
found <- AMR::antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
@ -312,16 +309,16 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# try by removing all spaces
if (x[i] %like% " ") {
found <- suppressWarnings(as.ab(gsub(" +", "", x[i], perl = TRUE), initial_search = FALSE))
if (length(found) > 0 & !is.na(found)) {
if (length(found) > 0 && !is.na(found)) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
}
# try by removing all spaces and numbers
if (x[i] %like% " " | x[i] %like% "[0-9]") {
if (x[i] %like% " " || x[i] %like% "[0-9]") {
found <- suppressWarnings(as.ab(gsub("[ 0-9]", "", x[i], perl = TRUE), initial_search = FALSE))
if (length(found) > 0 & !is.na(found)) {
if (length(found) > 0 && !is.na(found)) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
@ -477,7 +474,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
}
if (initial_search == TRUE & sum(already_known) < length(x)) {
if (initial_search == TRUE && sum(already_known) < length(x)) {
close(progress)
}
@ -566,7 +563,7 @@ as.data.frame.ab <- function(x, ...) {
"[<-.ab" <- function(i, j, ..., value) {
y <- NextMethod()
attributes(y) <- attributes(i)
return_after_integrity_check(y, "antimicrobial code", antibiotics$ab)
return_after_integrity_check(y, "antimicrobial code", AMR::antibiotics$ab)
}
#' @method [[<- ab
#' @export
@ -574,7 +571,7 @@ as.data.frame.ab <- function(x, ...) {
"[[<-.ab" <- function(i, j, ..., value) {
y <- NextMethod()
attributes(y) <- attributes(i)
return_after_integrity_check(y, "antimicrobial code", antibiotics$ab)
return_after_integrity_check(y, "antimicrobial code", AMR::antibiotics$ab)
}
#' @method c ab
#' @export
@ -583,7 +580,7 @@ c.ab <- function(...) {
x <- list(...)[[1L]]
y <- NextMethod()
attributes(y) <- attributes(x)
return_after_integrity_check(y, "antimicrobial code", antibiotics$ab)
return_after_integrity_check(y, "antimicrobial code", AMR::antibiotics$ab)
}
#' @method unique ab

16
R/ab_from_text.R
View File

@ -120,21 +120,21 @@ ab_from_text <- function(text,
if (type %like% "(drug|ab|anti)") {
translate_ab <- get_translate_ab(translate_ab)
if (isTRUE(thorough_search) |
(isTRUE(is.null(thorough_search)) & max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
if (isTRUE(thorough_search) ||
(isTRUE(is.null(thorough_search)) && max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
text_split_all <- text_split_all[nchar(text_split_all) >= 4 & grepl("[a-z]+", text_split_all)]
result <- lapply(text_split_all, function(text_split) {
progress$tick()
suppressWarnings(
out <- as.ab(text_split, ...)
as.ab(text_split, ...)
)
})
} else {
# no thorough search
abbr <- unlist(antibiotics$abbreviations)
abbr <- unlist(AMR::antibiotics$abbreviations)
abbr <- abbr[nchar(abbr) >= 4]
names_atc <- substr(c(antibiotics$name, antibiotics$atc), 1, 5)
synonyms <- unlist(antibiotics$synonyms)
names_atc <- substr(c(AMR::antibiotics$name, AMR::antibiotics$atc), 1, 5)
synonyms <- unlist(AMR::antibiotics$synonyms)
synonyms <- synonyms[nchar(synonyms) >= 4]
# regular expression must not be too long, so split synonyms in two:
synonyms_part1 <- synonyms[seq_len(0.5 * length(synonyms))]
@ -149,7 +149,7 @@ ab_from_text <- function(text,
result <- lapply(text_split_all, function(text_split) {
progress$tick()
suppressWarnings(
out <- as.ab(
as.ab(
unique(c(
text_split[text_split %like_case% to_regex(abbr)],
text_split[text_split %like_case% to_regex(names_atc)],
@ -176,7 +176,7 @@ ab_from_text <- function(text,
}
})
} else if (type %like% "dos") {
text_split_all <- strsplit(text, " ")
text_split_all <- strsplit(text, " ", fixed = TRUE)
result <- lapply(text_split_all, function(text_split) {
text_split <- text_split[text_split %like% "^[0-9]{2,}(/[0-9]+)?[a-z]*$"]
# only left part of "/", like 500 in "500/125"

26
R/ab_property.R
View File

@ -125,7 +125,7 @@
#' }
ab_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(tolower, allow_class = "logical", has_length = 1)
x <- translate_into_language(ab_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
@ -168,7 +168,7 @@ ab_tradenames <- function(x, ...) {
#' @export
ab_group <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(ab_validate(x = x, property = "group", ...), language = language, only_affect_ab_names = TRUE)
}
@ -208,7 +208,7 @@ ab_atc <- function(x, only_first = FALSE, ...) {
#' @export
ab_atc_group1 <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(ab_validate(x = x, property = "atc_group1", ...), language = language, only_affect_ab_names = TRUE)
}
@ -216,7 +216,7 @@ ab_atc_group1 <- function(x, language = get_AMR_locale(), ...) {
#' @export
ab_atc_group2 <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(ab_validate(x = x, property = "atc_group2", ...), language = language, only_affect_ab_names = TRUE)
}
@ -289,7 +289,7 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
#' @export
ab_info <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- as.ab(x, ...)
list(
@ -334,7 +334,7 @@ ab_url <- function(x, open = FALSE, ...) {
}
if (open == TRUE) {
if (length(u) > 1 & !is.na(u[1L])) {
if (length(u) > 1 && !is.na(u[1L])) {
warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
}
if (!is.na(u[1L])) {
@ -348,7 +348,7 @@ ab_url <- function(x, open = FALSE, ...) {
#' @export
ab_property <- function(x, property = "name", language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1)
meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1)
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(ab_validate(x = x, property = property, ...), language = language)
}
@ -358,8 +358,8 @@ ab_property <- function(x, property = "name", language = get_AMR_locale(), ...)
#' @export
set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale(), snake_case = NULL) {
meet_criteria(data, allow_class = c("data.frame", "character"))
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1, ignore.case = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1, ignore.case = TRUE)
language <- validate_language(language)
meet_criteria(snake_case, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
x_deparsed <- deparse(substitute(data))
@ -422,7 +422,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
x <- tolower(gsub("[^a-zA-Z0-9]+", "_", x))
}
if (any(duplicated(x))) {
if (anyDuplicated(x)) {
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
@ -433,7 +433,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
if (length(dups) > 1) {
# there are duplicates
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
x[dup_add_int] <<- paste0(x[dup_add_int], "_", 2:length(dups))
}
}
))
@ -448,15 +448,13 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
}
ab_validate <- function(x, property, ...) {
check_dataset_integrity()
if (tryCatch(all(x[!is.na(x)] %in% AB_lookup$ab), error = function(e) FALSE)) {
# special case for ab_* functions where class is already <ab>
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% antibiotics[1, property, drop = TRUE],
tryCatch(x[1L] %in% AMR::antibiotics[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE)
)

26
R/ab_selectors.R
View File

@ -420,8 +420,8 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os"
)
agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents_all <- AMR::antibiotics[which(!is.na(AMR::antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- AMR::antibiotics[which(AMR::antibiotics$ab %in% ab_in_data & !is.na(AMR::antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "administrable_per_os",
@ -458,8 +458,8 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv"
)
agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents_all <- AMR::antibiotics[which(!is.na(AMR::antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- AMR::antibiotics[which(AMR::antibiotics$ab %in% ab_in_data & !is.na(AMR::antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "administrable_iv",
@ -539,7 +539,7 @@ ab_select_exec <- function(function_name,
)
# untreatable drugs
if (only_treatable == TRUE) {
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
untreatable <- AMR::antibiotics[which(AMR::antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
if (any(untreatable %in% names(ab_in_data))) {
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_(
@ -782,16 +782,16 @@ find_ab_names <- function(ab_group, n = 3) {
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
# try popular first, they have DDDs
drugs <- antibiotics[which((!is.na(antibiotics$iv_ddd) | !is.na(antibiotics$oral_ddd)) &
antibiotics$name %unlike% " " &
antibiotics$group %like% ab_group &
antibiotics$ab %unlike% "[0-9]$"), ]$name
drugs <- AMR::antibiotics[which((!is.na(AMR::antibiotics$iv_ddd) | !is.na(AMR::antibiotics$oral_ddd)) &
AMR::antibiotics$name %unlike% " " &
AMR::antibiotics$group %like% ab_group &
AMR::antibiotics$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- antibiotics[which((antibiotics$group %like% ab_group |
antibiotics$atc_group1 %like% ab_group |
antibiotics$atc_group2 %like% ab_group) &
antibiotics$ab %unlike% "[0-9]$"), ]$name
drugs <- antibiotics[which((AMR::antibiotics$group %like% ab_group |
AMR::antibiotics$atc_group1 %like% ab_group |
AMR::antibiotics$atc_group2 %like% ab_group) &
AMR::antibiotics$ab %unlike% "[0-9]$"), ]$name
}
if (length(drugs) == 0) {
return("??")

2
R/amr.R
View File

@ -34,7 +34,7 @@
#' This package is fully independent of any other \R package and works on Windows, macOS and Linux with all versions of \R since R-3.0.0 (April 2013). It was designed to work in any setting, including those with very limited resources. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the University of Groningen, in collaboration with non-profit organisations Certe Medical Diagnostics and Advice and University Medical Center Groningen. This \R package is actively maintained and free software; you can freely use and distribute it for both personal and commercial (but not patent) purposes under the terms of the GNU General Public License version 2.0 (GPL-2), as published by the Free Software Foundation.
#'
#' This package can be used for:
#' - Reference for the taxonomy of microorganisms, since the package contains all microbial (sub)species from the Catalogue of Life and List of Prokaryotic names with Standing in Nomenclature
#' - Reference for the taxonomy of microorganisms, since the package contains all microbial (sub)species from the List of Prokaryotic names with Standing in Nomenclature (LPSN) and the Global Biodiversity Information Facility (GBIF)
#' - Interpreting raw MIC and disk diffusion values, based on the latest CLSI or EUCAST guidelines
#' - Retrieving antimicrobial drug names, doses and forms of administration from clinical health care records
#' - Determining first isolates to be used for AMR data analysis

8
R/atc_online.R
View File

@ -94,9 +94,7 @@ atc_online_property <- function(atc_code,
html_text <- import_fn("html_text", "rvest")
read_html <- import_fn("read_html", "xml2")
check_dataset_integrity()
if (!all(atc_code %in% unlist(antibiotics$atc))) {
if (!all(atc_code %in% unlist(AMR::antibiotics$atc))) {
atc_code <- as.character(ab_atc(atc_code, only_first = TRUE))
}
@ -183,7 +181,7 @@ atc_online_property <- function(atc_code,
# ATC and name are only in first row
returnvalue[i] <- out[1, property, drop = TRUE]
} else {
if (!"adm.r" %in% colnames(out) | is.na(out[1, "adm.r", drop = TRUE])) {
if (!"adm.r" %in% colnames(out) || is.na(out[1, "adm.r", drop = TRUE])) {
returnvalue[i] <- NA
next
} else {
@ -197,7 +195,7 @@ atc_online_property <- function(atc_code,
}
}
if (property == "groups" & length(returnvalue) == 1) {
if (property == "groups" && length(returnvalue) == 1) {
returnvalue <- returnvalue[[1]]
}

28
R/bug_drug_combinations.R
View File

@ -178,7 +178,7 @@ format.bug_drug_combinations <- function(x,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
@ -196,10 +196,10 @@ format.bug_drug_combinations <- function(x,
x <- data.frame(
mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
ab = gsub("(.*)%%(.*)", "\\2", names(idx)),
S = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE)),
I = sapply(idx, function(i) sum(x$I[i], na.rm = TRUE)),
R = sapply(idx, function(i) sum(x$R[i], na.rm = TRUE)),
total = sapply(idx, function(i) {
S = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$S[i], na.rm = TRUE)),
I = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$I[i], na.rm = TRUE)),
R = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$R[i], na.rm = TRUE)),
total = vapply(FUN.VALUE = double(1), idx, function(i) {
sum(x$S[i], na.rm = TRUE) +
sum(x$I[i], na.rm = TRUE) +
sum(x$R[i], na.rm = TRUE)
@ -214,7 +214,7 @@ format.bug_drug_combinations <- function(x,
if (remove_intrinsic_resistant == TRUE) {
x <- subset(x, R != total)
}
if (combine_SI == TRUE | combine_IR == FALSE) {
if (combine_SI == TRUE || combine_IR == FALSE) {
x$isolates <- x$R
} else {
x$isolates <- x$R + x$I
@ -224,13 +224,13 @@ format.bug_drug_combinations <- function(x,
format <- tolower(format)
ab_txt <- rep(format, length(ab))
for (i in seq_len(length(ab_txt))) {
ab_txt[i] <- gsub("ab", as.character(as.ab(ab[i])), ab_txt[i])
ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i])
ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i])
ab_txt[i] <- gsub("atc_group1", ab_atc_group1(ab[i], language = language), ab_txt[i])
ab_txt[i] <- gsub("atc_group2", ab_atc_group2(ab[i], language = language), ab_txt[i])
ab_txt[i] <- gsub("atc", ab_atc(ab[i], only_first = TRUE), ab_txt[i])
ab_txt[i] <- gsub("name", ab_name(ab[i], language = language), ab_txt[i])
ab_txt[i] <- gsub("ab", as.character(as.ab(ab[i])), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("atc_group1", ab_atc_group1(ab[i], language = language), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("atc_group2", ab_atc_group2(ab[i], language = language), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("atc", ab_atc(ab[i], only_first = TRUE), ab_txt[i], fixed = TRUE)
ab_txt[i] <- gsub("name", ab_name(ab[i], language = language), ab_txt[i], fixed = TRUE)
ab_txt[i]
}
ab_txt
@ -317,7 +317,7 @@ format.bug_drug_combinations <- function(x,
}
if (remove_intrinsic_resistant == TRUE) {
y <- y[, !vapply(FUN.VALUE = logical(1), y, function(col) all(col %like% "100", na.rm = TRUE) & !any(is.na(col))), drop = FALSE]
y <- y[, !vapply(FUN.VALUE = logical(1), y, function(col) all(col %like% "100", na.rm = TRUE) & !anyNA(col)), drop = FALSE]
}
rownames(y) <- NULL

145
R/catalogue_of_life.R
View File

@ -1,145 +0,0 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Data Analysis for R #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
format_included_data_number <- function(data) {
if (is.data.frame(data)) {
n <- nrow(data)
} else {
n <- length(unique(data))
}
if (n > 10000) {
rounder <- -3 # round on thousands
} else if (n > 1000) {
rounder <- -2 # round on hundreds
} else {
rounder <- -1 # round on tens
}
paste0("~", format(round(n, rounder), decimal.mark = ".", big.mark = ","))
}
#' The Catalogue of Life
#'
#' This package contains the complete taxonomic tree (last updated: `r CATALOGUE_OF_LIFE$yearmonth_LPSN`) of almost all microorganisms from the authoritative and comprehensive Catalogue of Life (CoL), supplemented with data from the List of Prokaryotic names with Standing in Nomenclature (LPSN).
#' @section Catalogue of Life:
#' \if{html}{\figure{logo_col.png}{options: height="40" style=margin-bottom:"5"} \cr}
#' This package contains the complete taxonomic tree of almost all microorganisms (`r format_included_data_number(microorganisms)` species) from the authoritative and comprehensive Catalogue of Life (CoL, <http://www.catalogueoflife.org>). The CoL is the most comprehensive and authoritative global index of species currently available. Nonetheless, we supplemented the CoL data with data from the List of Prokaryotic names with Standing in Nomenclature (LPSN, [lpsn.dsmz.de](https://lpsn.dsmz.de)). This supplementation is needed until the [CoL+ project](https://github.com/CatalogueOfLife/general) is finished, which we await.
#'
#' [Click here][catalogue_of_life] for more information about the included taxa. Check which versions of the CoL and LPSN were included in this package with [catalogue_of_life_version()].
#' @section Included Taxa:
#' Included are:
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom %in% c("Archeae", "Bacteria", "Chromista", "Protozoa")), , drop = FALSE])` (sub)species from the kingdoms of Archaea, Bacteria, Chromista and Protozoa
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), , drop = FALSE])` (sub)species from these orders of the kingdom of Fungi: Eurotiales, Microascales, Mucorales, Onygenales, Pneumocystales, Saccharomycetales, Schizosaccharomycetales and Tremellales, as well as `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi" & !microorganisms$order %in% c("Eurotiales", "Microascales", "Mucorales", "Onygenales", "Pneumocystales", "Saccharomycetales", "Schizosaccharomycetales", "Tremellales")), ])` other fungal (sub)species. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including the aforementioned taxonomic orders, the most relevant fungi are covered (such as all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), , drop = FALSE])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus", drop = TRUE])` other relevant genera from the kingdom of Animalia (such as *Strongyloides* and *Taenia*)
#' - All `r format_included_data_number(microorganisms.old)` previously accepted names of all included (sub)species (these were taxonomically renamed)
#' - The complete taxonomic tree of all included (sub)species: from kingdom to subspecies
#' - The responsible author(s) and year of scientific publication
#'
#' The Catalogue of Life (<http://www.catalogueoflife.org>) is the most comprehensive and authoritative global index of species currently available. It holds essential information on the names, relationships and distributions of over 1.9 million species. The Catalogue of Life is used to support the major biodiversity and conservation information services such as the Global Biodiversity Information Facility (GBIF), Encyclopedia of Life (EoL) and the International Union for Conservation of Nature Red List. It is recognised by the Convention on Biological Diversity as a significant component of the Global Taxonomy Initiative and a contribution to Target 1 of the Global Strategy for Plant Conservation.
#'
#' The syntax used to transform the original data to a cleansed \R format, can be found here: <https://github.com/msberends/AMR/blob/main/data-raw/reproduction_of_microorganisms.R>.
#' @name catalogue_of_life
#' @rdname catalogue_of_life
#' @seealso Data set [microorganisms] for the actual data. \cr
#' Function [as.mo()] to use the data for intelligent determination of microorganisms.
#' @examples
#' # Get version info of included data set
#' catalogue_of_life_version()
#'
#'
#' # Get a note when a species was renamed
#' mo_shortname("Chlamydophila psittaci")
#'
#' # Get any property from the entire taxonomic tree for all included species
#' mo_class("Escherichia coli")
#'
#' mo_family("Escherichia coli")
#'
#' mo_gramstain("Escherichia coli") # based on kingdom and phylum, see ?mo_gramstain
#'
#' mo_ref("Escherichia coli")
#'
#' # Do not get mistaken - this package is about microorganisms
#' mo_kingdom("C. elegans")
#' mo_name("C. elegans")
NULL
#' Version info of included Catalogue of Life
#'
#' This function returns information about the included data from the Catalogue of Life.
#' @seealso [microorganisms]
#' @details For LPSN, see [microorganisms].
#' @return a [list], which prints in pretty format
#' @inheritSection catalogue_of_life Catalogue of Life
#' @export
catalogue_of_life_version <- function() {
check_dataset_integrity()
# see the `CATALOGUE_OF_LIFE` list in R/globals.R
lst <- list(
CoL =
list(
version = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE),
url = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$url_CoL, fixed = TRUE),
n = nrow(pm_filter(microorganisms, source == "CoL"))
),
LPSN =
list(
version = "List of Prokaryotic names with Standing in Nomenclature",
url = CATALOGUE_OF_LIFE$url_LPSN,
yearmonth = CATALOGUE_OF_LIFE$yearmonth_LPSN,
n = nrow(pm_filter(microorganisms, source == "LPSN"))
),
total_included =
list(
n_total_species = nrow(microorganisms),
n_total_synonyms = nrow(microorganisms.old)
)
)
set_clean_class(lst,
new_class = c("catalogue_of_life_version", "list")
)
}
#' @method print catalogue_of_life_version
#' @export
#' @noRd
print.catalogue_of_life_version <- function(x, ...) {
cat(paste0(
font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
font_underline(x$CoL$version), "\n",
" Available at: ", font_blue(x$CoL$url), "\n",
" Number of included microbial species: ", format(x$CoL$n, big.mark = ","), "\n",
font_underline(paste0(
x$LPSN$version, " (",
x$LPSN$yearmonth, ")"
)), "\n",
" Available at: ", font_blue(x$LPSN$url), "\n",
" Number of included bacterial species: ", format(x$LPSN$n, big.mark = ","), "\n\n",
"=> Total number of species included: ", format(x$total_included$n_total_species, big.mark = ","), "\n",
"=> Total number of synonyms included: ", format(x$total_included$n_total_synonyms, big.mark = ","), "\n\n",
"See for more info ", font_grey_bg("`?microorganisms`"), " and ", font_grey_bg("`?catalogue_of_life`"), ".\n"
))
}

12
R/custom_eucast_rules.R
View File

@ -207,11 +207,11 @@ print.custom_eucast_rules <- function(x, ...) {
if (is.na(rule$result_value)) {
val <- font_red("<NA>")
} else if (rule$result_value == "R") {
val <- font_rsi_R_bg(font_black(" R "))
val <- font_red_bg(" R ")
} else if (rule$result_value == "S") {
val <- font_rsi_S_bg(font_black(" S "))
val <- font_green_bg(" S ")
} else {
val <- font_rsi_I_bg(font_black(" I "))
val <- font_orange_bg(" I ")
}
agents <- paste0(
font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
@ -248,9 +248,9 @@ format_custom_query_rule <- function(query, colours = has_colour()) {
query <- gsub(" %in% ", font_black(" is one of "), query, fixed = TRUE)
query <- gsub(" %like% ", font_black(" resembles "), query, fixed = TRUE)
if (colours == TRUE) {
query <- gsub('"R"', font_rsi_R_bg(font_black(" R ")), query, fixed = TRUE)
query <- gsub('"S"', font_rsi_S_bg(font_black(" S ")), query, fixed = TRUE)
query <- gsub('"I"', font_rsi_I_bg(font_black(" I ")), query, fixed = TRUE)
query <- gsub('"R"', font_red_bg(" R "), query, fixed = TRUE)
query <- gsub('"S"', font_green_bg(" S "), query, fixed = TRUE)
query <- gsub('"I"', font_orange_bg(" I "), query, fixed = TRUE)
}
# replace the black colour 'stops' with blue colour 'starts'
query <- gsub("\033[39m", "\033[34m", as.character(query), fixed = TRUE)

77
R/data.R
View File

@ -74,81 +74,67 @@
#' Data Set with `r format(nrow(microorganisms), big.mark = ",")` Microorganisms
#'
#' A data set containing the full microbial taxonomy (**last updated: `r CATALOGUE_OF_LIFE$yearmonth_LPSN`**) of `r nr2char(length(unique(microorganisms$kingdom[!microorganisms$kingdom %like% "unknown"])))` kingdoms from the Catalogue of Life (CoL) and the List of Prokaryotic names with Standing in Nomenclature (LPSN). MO codes can be looked up using [as.mo()].
#' @inheritSection catalogue_of_life Catalogue of Life
#' A data set containing the full microbial taxonomy (**last updated: `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`**) of `r nr2char(length(unique(microorganisms$kingdom[!microorganisms$kingdom %like% "unknown"])))` kingdoms from the List of Prokaryotic names with Standing in Nomenclature (LPSN) and the Global Biodiversity Information Facility (GBIF). This data set is the backbone of this `AMR` package. MO codes can be looked up using [as.mo()].
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms), big.mark = ",")` observations and `r ncol(microorganisms)` variables:
#' - `mo`\cr ID of microorganism as used by this package
#' - `fullname`\cr Full name, like `"Escherichia coli"`
#' - `fullname`\cr Full name, like `"Escherichia coli"`. For the taxonomic ranks genus, species and subspecies, this is the 'pasted' text of genus, species, and subspecies. For all taxonomic ranks higher than genus, this is the name of the taxon.
#' - `status` \cr Status of the taxon, either `r vector_or(microorganisms$status)`
#' - `kingdom`, `phylum`, `class`, `order`, `family`, `genus`, `species`, `subspecies`\cr Taxonomic rank of the microorganism
#' - `rank`\cr Text of the taxonomic rank of the microorganism, like `"species"` or `"genus"`
#' - `ref`\cr Author(s) and year of concerning scientific publication
#' - `species_id`\cr ID of the species as used by the Catalogue of Life
#' - `rank`\cr Text of the taxonomic rank of the microorganism, such as `"species"` or `"genus"`
#' - `ref`\cr Author(s) and year of related scientific publication. This contains only the *first surname* and year of the *latest* authors, e.g. "Wallis *et al.* 2006 *emend.* Smith and Jones 2018" becomes "Smith *et al.*, 2018". This field is directly retrieved from the source specified in the column `source`. Moreover, accents were removed to comply with CRAN that only allows ASCII characters, e.g. "V`r "\u00e1\u0148ov\u00e1"`" becomes "Vanova".
#' - `lpsn`\cr Identifier ('Record number') of the List of Prokaryotic names with Standing in Nomenclature (LPSN). This will be the first/highest LPSN identifier to keep one identifier per row. For example, *Acetobacter ascendens* has LPSN Record number 7864 and 11011. Only the first is available in the `microorganisms` data set.
#' - `lpsn_parent`\cr LPSN identifier of the parent taxon
#' - `lpsn_renamed_to`\cr LPSN identifier of the currently valid taxon
#' - `gbif`\cr Identifier ('taxonID') of the Global Biodiversity Information Facility (GBIF)
#' - `gbif_parent`\cr GBIF identifier of the parent taxon
#' - `gbif_renamed_to`\cr GBIF identifier of the currently valid taxon
#' - `source`\cr Either `r vector_or(microorganisms$source)` (see *Source*)
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
#' - `snomed`\cr Systematized Nomenclature of Medicine (SNOMED) code of the microorganism, according to the `r SNOMED_VERSION$current_source` (see *Source*). Use [mo_snomed()] to retrieve it quickly, see [mo_property()].
#' - `snomed`\cr Systematized Nomenclature of Medicine (SNOMED) code of the microorganism, version of `r documentation_date(TAXONOMY_VERSION$SNOMED$accessed_date)` (see *Source*). Use [mo_snomed()] to retrieve it quickly, see [mo_property()].
#' @details
#' Please note that entries are only based on the Catalogue of Life and the LPSN (see below). Since these sources incorporate entries based on (recent) publications in the International Journal of Systematic and Evolutionary Microbiology (IJSEM), it can happen that the year of publication is sometimes later than one might expect.
#' Please note that entries are only based on the List of Prokaryotic names with Standing in Nomenclature (LPSN) and the Global Biodiversity Information Facility (GBIF) (see below). Since these sources incorporate entries based on (recent) publications in the International Journal of Systematic and Evolutionary Microbiology (IJSEM), it can happen that the year of publication is sometimes later than one might expect.
#'
#' For example, *Staphylococcus pettenkoferi* was described for the first time in Diagnostic Microbiology and Infectious Disease in 2002 (\doi{10.1016/s0732-8893(02)00399-1}), but it was not before 2007 that a publication in IJSEM followed (\doi{10.1099/ijs.0.64381-0}). Consequently, the `AMR` package returns 2007 for `mo_year("S. pettenkoferi")`.
#'
#' @section Included Taxa:
#' Included taxonomic data are:
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom %in% c("Archeae", "Bacteria", "Protozoa")), , drop = FALSE])` (sub)species from the kingdoms of Archaea, Bacteria and Protozoa
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi"), , drop = FALSE])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Fungi"), "order", drop = TRUE])` relevant orders of the kingdom of Fungi. The kingdom of Fungi is a very large taxon with almost 300,000 different (sub)species, of which most are not microbial (but rather macroscopic, like mushrooms). Because of this, not all fungi fit the scope of this package and including everything would tremendously slow down our algorithms too. By only including relevant taxonomic orders, the most relevant fungi are covered (such as all species of *Aspergillus*, *Candida*, *Cryptococcus*, *Histplasma*, *Pneumocystis*, *Saccharomyces* and *Trichophyton*).
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), , drop = FALSE])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus", drop = TRUE])` other relevant genera from the kingdom of Animalia (such as *Strongyloides* and *Taenia*)
#' - All `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Plantae"), , drop = FALSE])` (sub)species from `r format_included_data_number(microorganisms[which(microorganisms$kingdom == "Animalia"), "genus", drop = TRUE])` other relevant genera from the kingdom of Animalia (such as *Strongyloides* and *Taenia*)
#' - All `r format_included_data_number(microorganisms[which(microorganisms$status != "accepted"), , drop = FALSE])` previously accepted names of all included (sub)species (these were taxonomically renamed)
#' - The complete taxonomic tree of all included (sub)species: from kingdom to subspecies
#' - The identifier of the parent taxons
#' - The responsible author(s) and year of scientific publication
#'
#' ## Manual additions
#' For convenience, some entries were added manually:
#'
#' - 11 entries of *Streptococcus* (beta-haemolytic: groups A, B, C, D, F, G, H, K and unspecified; other: viridans, milleri)
#' - 2 entries of *Staphylococcus* (coagulase-negative (CoNS) and coagulase-positive (CoPS))
#' - 3 entries of *Trichomonas* (*T. vaginalis*, and its family and genus)
#' - 4 entries of *Toxoplasma* (*T. gondii*, and its order, family and genus)
#' - 1 entry of *Candida* (*C. krusei*), that is not (yet) in the Catalogue of Life
#' - 1 entry of *Blastocystis* (*B. hominis*), although it officially does not exist (Noel *et al.* 2005, PMID 15634993)
#' - 1 entry of *Moraxella* (*M. catarrhalis*), which was formally named *Branhamella catarrhalis* (Catlin, 1970) though this change was never accepted within the field of clinical microbiology
#' - 5 other 'undefined' entries (unknown, unknown Gram negatives, unknown Gram positives, unknown yeast and unknown fungus)
#' - 6 families under the Enterobacterales order, according to Adeolu *et al.* (2016, PMID 27620848), that are not (yet) in the Catalogue of Life
#'
#' The syntax used to transform the original data to a cleansed \R format, can be found here: <https://github.com/msberends/AMR/blob/main/data-raw/reproduction_of_microorganisms.R>.
#'
#' ## Direct download
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @section About the Records from LPSN (see *Source*):
#' LPSN is the main source for bacteriological taxonomy of this `AMR` package.
#'
#' The List of Prokaryotic names with Standing in Nomenclature (LPSN) provides comprehensive information on the nomenclature of prokaryotes. LPSN is a free to use service founded by Jean P. Euzeby in 1997 and later on maintained by Aidan C. Parte.
#'
#' As of February 2020, the regularly augmented LPSN database at DSMZ is the basis of the new LPSN service. The new database was implemented for the Type-Strain Genome Server and augmented in 2018 to store all kinds of nomenclatural information. Data from the previous version of LPSN and from the Prokaryotic Nomenclature Up-to-date (PNU) service were imported into the new system. PNU had been established in 1993 as a service of the Leibniz Institute DSMZ, and was curated by Norbert Weiss, Manfred Kracht and Dorothea Gleim.
#' @source
#' `r gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE)` as currently implemented in this `AMR` package:
#' * `r TAXONOMY_VERSION$LPSN$citation` Accessed from <`r TAXONOMY_VERSION$LPSN$url`> on `r documentation_date(TAXONOMY_VERSION$LPSN$accessed_date)`.
#'
#' * Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org>
#' * `r TAXONOMY_VERSION$GBIF$citation` Accessed from <`r TAXONOMY_VERSION$GBIF$url`> on `r documentation_date(TAXONOMY_VERSION$GBIF$accessed_date)`.
#'
#' List of Prokaryotic names with Standing in Nomenclature (`r CATALOGUE_OF_LIFE$yearmonth_LPSN`) as currently implemented in this `AMR` package:
#'
#' * Parte, A.C., Sarda Carbasse, J., Meier-Kolthoff, J.P., Reimer, L.C. and Goker, M. (2020). List of Prokaryotic names with Standing in Nomenclature (LPSN) moves to the DSMZ. International Journal of Systematic and Evolutionary Microbiology, 70, 5607-5612; \doi{10.1099/ijsem.0.004332}
#' * Parte, A.C. (2018). LPSN - List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; \doi{10.1099/ijsem.0.002786}
#' * Parte, A.C. (2014). LPSN - List of Prokaryotic names with Standing in Nomenclature. Nucleic Acids Research, 42, Issue D1, D613-D616; \doi{10.1093/nar/gkt1111}
#' * Euzeby, J.P. (1997). List of Bacterial Names with Standing in Nomenclature: a Folder Available on the Internet. International Journal of Systematic Bacteriology, 47, 590-592; \doi{10.1099/00207713-47-2-590}
#'
#' `r SNOMED_VERSION$current_source` as currently implemented in this `AMR` package:
#'
#' * Retrieved from the `r SNOMED_VERSION$title`, OID `r SNOMED_VERSION$current_oid`, version `r SNOMED_VERSION$current_version`; url: <`r SNOMED_VERSION$url`>
#' * `r TAXONOMY_VERSION$SNOMED$citation` URL: <`r TAXONOMY_VERSION$SNOMED$url`>
#' @seealso [as.mo()], [mo_property()], [microorganisms.codes], [intrinsic_resistant]
#' @examples
#' microorganisms
"microorganisms"
#' Data Set with Previously Accepted Taxonomic Names
#'
#' A data set containing old (previously valid or accepted) taxonomic names according to the Catalogue of Life. This data set is used internally by [as.mo()].
#' @inheritSection catalogue_of_life Catalogue of Life
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms.old), big.mark = ",")` observations and `r ncol(microorganisms.old)` variables:
#' - `fullname`\cr Old full taxonomic name of the microorganism
#' - `fullname_new`\cr New full taxonomic name of the microorganism
#' - `ref`\cr Author(s) and year of concerning scientific publication
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @source Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
#'
#' Parte, A.C. (2018). LPSN - List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; \doi{10.1099/ijsem.0.002786}
#' @seealso [as.mo()] [mo_property()] [microorganisms]
#' @examples
#' microorganisms.old
"microorganisms.old"
#' Data Set with `r format(nrow(microorganisms.codes), big.mark = ",")` Common Microorganism Codes
#'
#' A data set containing commonly used codes for microorganisms, from laboratory systems and WHONET. Define your own with [set_mo_source()]. They will all be searched when using [as.mo()] and consequently all the [`mo_*`][mo_property()] functions.
@ -157,7 +143,6 @@
#' - `mo`\cr ID of the microorganism in the [microorganisms] data set
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @inheritSection catalogue_of_life Catalogue of Life
#' @seealso [as.mo()] [microorganisms]
#' @examples
#' microorganisms.codes

4
R/disk.R
View File

@ -79,7 +79,7 @@ as.disk <- function(x, na.rm = FALSE) {
# heavily based on cleaner::clean_double():
clean_double2 <- function(x, remove = "[^0-9.,-]", fixed = FALSE) {
x <- gsub(",", ".", x)
x <- gsub(",", ".", x, fixed = TRUE)
# remove ending dot/comma
x <- gsub("[,.]$", "", x)
# only keep last dot/comma
@ -131,7 +131,7 @@ all_valid_disks <- function(x) {
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
error = function(e) NA
)
!any(is.na(x_disk)) && !all(is.na(x))
!anyNA(x_disk) && !all(is.na(x))
}
#' @rdname as.disk

25
R/eucast_rules.R
View File

@ -46,14 +46,13 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
))
}
}
vector_and(txt, quotes = FALSE)
}
#' Apply EUCAST Rules
#'
#' @description
#' Apply rules for clinical breakpoints and intrinsic resistance as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
#' Apply rules for clinical breakpoints and intrinsic resistance as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://www.eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
#'
#' To improve the interpretation of the antibiogram before EUCAST rules are applied, some non-EUCAST rules can applied at default, see *Details*.
#' @param x a data set with antibiotic columns, such as `amox`, `AMX` and `AMC`
@ -73,7 +72,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' **Note:** This function does not translate MIC values to RSI values. Use [as.rsi()] for that. \cr
#' **Note:** When ampicillin (AMP, J01CA01) is not available but amoxicillin (AMX, J01CA04) is, the latter will be used for all rules where there is a dependency on ampicillin. These drugs are interchangeable when it comes to expression of antimicrobial resistance. \cr
#'
#' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/main/data-raw/eucast_rules.tsv>. **Note:** Old taxonomic names are replaced with the current taxonomy where applicable. For example, *Ochrobactrum anthropi* was renamed to *Brucella anthropi* in 2020; the original EUCAST rules v3.1 and v3.2 did not yet contain this new taxonomic name. The file used as input for this `AMR` package contains the taxonomy updated until [`r CATALOGUE_OF_LIFE$yearmonth_LPSN`][catalogue_of_life()].
#' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/main/data-raw/eucast_rules.tsv>. **Note:** Old taxonomic names are replaced with the current taxonomy where applicable. For example, *Ochrobactrum anthropi* was renamed to *Brucella anthropi* in 2020; the original EUCAST rules v3.1 and v3.2 did not yet contain this new taxonomic name. The `AMR` package contains the full microbial taxonomy updated until `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`, see [microorganisms].
#'
#' ## Custom Rules
#'
@ -199,8 +198,6 @@ eucast_rules <- function(x,
x_deparsed <- "your_data"
}
check_dataset_integrity()
breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
@ -334,7 +331,7 @@ eucast_rules <- function(x,
strsplit(",") %pm>%
unlist() %pm>%
trimws() %pm>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE, fast_mode = TRUE) else x) %pm>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE, fast_mode = TRUE) else x) %pm>%
sort() %pm>%
paste(collapse = ", ")
x <- gsub("_", " ", x, fixed = TRUE)
@ -423,13 +420,13 @@ eucast_rules <- function(x,
# big speed gain! only analyse unique rows:
pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = info)
# rename col_mo to prevent interference with joined columns
colnames(x)[colnames(x) == col_mo] <- ".col_mo"
col_mo <- ".col_mo"
# join to microorganisms data set
x <- left_join_microorganisms(x, by = col_mo, suffix = c("_oldcols", ""))
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL)
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE)
x$genus_species <- trimws(paste(x$genus, x$species))
if (info == TRUE & NROW(x) > 10000) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
@ -437,11 +434,11 @@ eucast_rules <- function(x,
if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
all_staph <- MO_lookup[which(MO_lookup$genus == "Staphylococcus"), , drop = FALSE]
all_staph$CNS_CPS <- suppressWarnings(mo_name(all_staph$mo, Becker = "all", language = NULL))
all_staph$CNS_CPS <- suppressWarnings(mo_name(all_staph$mo, Becker = "all", language = NULL, info = FALSE))
}
if (any(x$genus == "Streptococcus", na.rm = TRUE)) {
all_strep <- MO_lookup[which(MO_lookup$genus == "Streptococcus"), , drop = FALSE]
all_strep$Lancefield <- suppressWarnings(mo_name(all_strep$mo, Lancefield = TRUE, language = NULL))
all_strep$Lancefield <- suppressWarnings(mo_name(all_strep$mo, Lancefield = TRUE, language = NULL, info = FALSE))
}
n_added <- 0
@ -461,10 +458,10 @@ eucast_rules <- function(x,
))
))
}
ab_enzyme <- subset(antibiotics, name %like% "/")[, c("ab", "name"), drop = FALSE]
ab_enzyme <- subset(AMR::antibiotics, name %like% "/")[, c("ab", "name"), drop = FALSE]
colnames(ab_enzyme) <- c("enzyme_ab", "enzyme_name")
ab_enzyme$base_name <- gsub("^([a-zA-Z0-9]+).*", "\\1", ab_enzyme$enzyme_name)
ab_enzyme$base_ab <- antibiotics[match(ab_enzyme$base_name, antibiotics$name), "ab", drop = TRUE]
ab_enzyme$base_ab <- AMR::antibiotics[match(ab_enzyme$base_name, AMR::antibiotics$name), "ab", drop = TRUE]
ab_enzyme <- subset(ab_enzyme, !is.na(base_ab))
# make ampicillin and amoxicillin interchangable
ampi <- subset(ab_enzyme, base_ab == "AMX")
@ -1073,11 +1070,11 @@ edit_rsi <- function(x,
)
txt_error <- function() {
if (info == TRUE) cat("", font_red_bg(font_white(" ERROR ")), "\n\n")
if (info == TRUE) cat("", font_red_bg(" ERROR "), "\n\n")
}
txt_warning <- function() {
if (warned == FALSE) {
if (info == TRUE) cat(" ", font_rsi_I_bg(" WARNING "), sep = "")
if (info == TRUE) cat(" ", font_orange_bg(" WARNING "), sep = "")
}
warned <<- TRUE
}

40
R/first_isolate.R
View File

@ -174,18 +174,6 @@ first_isolate <- function(x = NULL,
include_unknown = FALSE,
include_untested_rsi = TRUE,
...) {
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
dots.names <- names(dots)
if ("filter_specimen" %in% dots.names) {
specimen_group <- dots[which(dots.names == "filter_specimen")]
}
if ("col_keyantibiotics" %in% dots.names) {
col_keyantimicrobials <- dots[which(dots.names == "col_keyantibiotics")]
}
}
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
@ -248,10 +236,10 @@ first_isolate <- function(x = NULL,
FUN = function(x) any(as.character(x[1:10000]) %in% c("R", "S", "I"), na.rm = TRUE),
USE.NAMES = FALSE
))
if (method == "phenotype-based" & !any_col_contains_rsi) {
if (method == "phenotype-based" && !any_col_contains_rsi) {
method <- "episode-based"
}
if (info == TRUE & message_not_thrown_before("first_isolate", "method")) {
if (info == TRUE && message_not_thrown_before("first_isolate", "method")) {
message_(paste0(
"Determining first isolates ",
ifelse(method %in% c("episode-based", "phenotype-based"),
@ -288,14 +276,14 @@ first_isolate <- function(x = NULL,
} else if (method == "episode-based") {
col_keyantimicrobials <- NULL
} else if (method == "phenotype-based") {
if (missing(type) & !is.null(col_keyantimicrobials)) {
if (missing(type) && !is.null(col_keyantimicrobials)) {
# type = "points" is default, but not set explicitly, while col_keyantimicrobials is
type <- "keyantimicrobials"
}
if (type == "points") {
x$keyantimicrobials <- all_antimicrobials(x, only_rsi_columns = FALSE)
col_keyantimicrobials <- "keyantimicrobials"
} else if (type == "keyantimicrobials" & is.null(col_keyantimicrobials)) {
} else if (type == "keyantimicrobials" && is.null(col_keyantimicrobials)) {
col_keyantimicrobials <- search_type_in_df(x = x, type = "keyantimicrobials", info = info)
if (is.null(col_keyantimicrobials)) {
# still not found as a column, create it ourselves
@ -325,7 +313,7 @@ first_isolate <- function(x = NULL,
}
# -- specimen
if (is.null(col_specimen) & !is.null(specimen_group)) {
if (is.null(col_specimen) && !is.null(specimen_group)) {
col_specimen <- search_type_in_df(x = x, type = "specimen", info = info)
}
@ -361,7 +349,7 @@ first_isolate <- function(x = NULL,
testcodes_exclude <- NULL
}
# remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate", "excludingtestcodes")) {
if (!is.null(testcodes_exclude) && info == TRUE && message_not_thrown_before("first_isolate", "excludingtestcodes")) {
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
add_fn = font_black,
as_note = FALSE
@ -375,7 +363,7 @@ first_isolate <- function(x = NULL,
# filter on specimen group and keyantibiotics when they are filled in
if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x)
if (info == TRUE & message_not_thrown_before("first_isolate", "excludingspecimen")) {
if (info == TRUE && message_not_thrown_before("first_isolate", "excludingspecimen")) {
message_("Excluding other than specimen group '", specimen_group, "'",
add_fn = font_black,
as_note = FALSE
@ -418,7 +406,7 @@ first_isolate <- function(x = NULL,
}
# speed up - return immediately if obvious
if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (abs(row.start) == Inf || abs(row.end) == Inf) {
if (info == TRUE) {
message_("=> Found ", font_bold("no isolates"),
add_fn = font_black,
@ -455,7 +443,7 @@ first_isolate <- function(x = NULL,
# Analysis of first isolate ----
if (!is.null(col_keyantimicrobials)) {
if (info == TRUE & message_not_thrown_before("first_isolate", "type")) {
if (info == TRUE && message_not_thrown_before("first_isolate", "type")) {
if (type == "keyantimicrobials") {
message_("Basing inclusion on key antimicrobials, ",
ifelse(ignore_I == FALSE, "not ", ""),
@ -474,11 +462,7 @@ first_isolate <- function(x = NULL,
}
}
x$other_pat_or_mo <- ifelse(x$newvar_patient_id == pm_lag(x$newvar_patient_id) &
x$newvar_genus_species == pm_lag(x$newvar_genus_species),
FALSE,
TRUE
)
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist(lapply(split(
@ -570,7 +554,7 @@ first_isolate <- function(x = NULL,
}
# handle empty microorganisms
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) && info == TRUE) {
message_(
ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
@ -582,7 +566,7 @@ first_isolate <- function(x = NULL,
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
# exclude all NAs
if (any(is.na(x$newvar_mo)) & info == TRUE) {
if (anyNA(x$newvar_mo) && info == TRUE) {
message_(
"Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark

2
R/g.test.R
View File

@ -149,7 +149,7 @@ g.test <- function(x,
paste(DNAME2, collapse = "\n")
)
}
if (any(x < 0) || any(is.na((x)))) { # this last one was anyNA, but only introduced in R 3.1.0
if (any(x < 0) || anyNA(x)) {
stop("all entries of 'x' must be nonnegative and finite")
}
if ((n <- sum(x)) == 0) {

4
R/ggplot_pca.R
View File

@ -232,7 +232,7 @@ ggplot_pca <- function(x,
}
# Overlay a concentration ellipse if there are groups
if (!is.null(df.u$groups) & !is.null(ell) & isTRUE(ellipse)) {
if (!is.null(df.u$groups) && !is.null(ell) && isTRUE(ellipse)) {
g <- g + ggplot2::geom_path(
data = ell,
ggplot2::aes(colour = groups, group = groups),
@ -319,7 +319,7 @@ pca_calculations <- function(pca_model,
error = function(e) NULL
)
}
if (!is.null(groups) & is.null(labels)) {
if (!is.null(groups) && is.null(labels)) {
# turn them around
labels <- groups
groups <- NULL

8
R/ggplot_rsi.R
View File

@ -211,7 +211,7 @@ ggplot_rsi <- function(data,
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(colours, allow_class = c("character", "logical"))
meet_criteria(datalabels, allow_class = "logical", has_length = 1)
@ -311,12 +311,12 @@ geom_rsi <- function(position = NULL,
meet_criteria(fill, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
y <- "value"
if (missing(position) | is.null(position)) {
if (missing(position) || is.null(position)) {
position <- "fill"
}
@ -500,7 +500,7 @@ labels_rsi_count <- function(position = NULL,
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)

12
R/guess_ab_col.R
View File

@ -59,7 +59,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
if (is.null(x) & is.null(search_string)) {
if (is.null(x) && is.null(search_string)) {
return(as.name("guess_ab_col"))
} else {
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = FALSE)
@ -205,7 +205,7 @@ get_column_abx <- function(x,
dots <- dots[!vapply(FUN.VALUE = logical(1), dots, is.data.frame)]
if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
if (any(is.na(newnames))) {
if (anyNA(newnames)) {
if (info == TRUE) {
message_(" WARNING", add_fn = list(font_yellow, font_bold), as_note = FALSE)
}
@ -236,7 +236,7 @@ get_column_abx <- function(x,
}
if (length(out) == 0) {
if (info == TRUE & all_okay == TRUE) {
if (info == TRUE && all_okay == TRUE) {
message_("No columns found.")
}
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE, match_fn = fn)
@ -262,7 +262,7 @@ get_column_abx <- function(x,
message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
}
for (i in seq_len(length(out))) {
if (verbose == TRUE & !names(out[i]) %in% names(duplicates)) {
if (verbose == TRUE && !names(out[i]) %in% names(duplicates)) {
message_(
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
@ -300,7 +300,7 @@ get_column_abx <- function(x,
}
if (!is.null(soft_dependencies)) {
soft_dependencies <- unique(soft_dependencies)
if (info == TRUE & !all(soft_dependencies %in% names(out))) {
if (info == TRUE && !all(soft_dependencies %in% names(out))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(out)]
missing_msg <- vector_and(paste0(
@ -325,7 +325,7 @@ get_column_abx <- function(x,
get_ab_from_namespace <- function(x, cols_ab) {
# cols_ab comes from get_column_abx()
x <- trimws(unique(toupper(unlist(strsplit(x, ",")))))
x <- trimws(unique(toupper(unlist(strsplit(x, ",", fixed = TRUE)))))
x_new <- character()
for (val in x) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {

2
R/italicise_taxonomy.R
View File

@ -62,7 +62,7 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
FUN.VALUE = character(1),
string,
function(s) {
s_split <- unlist(strsplit(s, " "))
s_split <- unlist(strsplit(s, " ", fixed = TRUE))
search_strings <- gsub("[^a-zA-Z-]", "", s_split)

2
R/join_microorganisms.R
View File

@ -123,8 +123,6 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
}
join_microorganisms <- function(type, x, by, suffix, ...) {
check_dataset_integrity()
if (!is.data.frame(x)) {
if (pkg_is_available("tibble", also_load = FALSE)) {
x <- import_fn("tibble", "tibble")(mo = x)

11
R/key_antimicrobials.R
View File

@ -175,8 +175,8 @@ key_antimicrobials <- function(x = NULL,
values <- cols[names(cols) %in% values]
values_new_length <- length(values)
if (values_new_length < values_old_length &
any(filter, na.rm = TRUE) &
if (values_new_length < values_old_length &&
any(filter, na.rm = TRUE) &&
message_not_thrown_before("key_antimicrobials", name)) {
warning_(
"in `key_antimicrobials()`: ",
@ -305,7 +305,7 @@ antimicrobials_equal <- function(y,
stop_ifnot(length(y) == length(z), "length of `y` and `z` must be equal")
key2rsi <- function(val) {
val <- strsplit(val, "")[[1L]]
val <- strsplit(val, "", fixed = TRUE)[[1L]]
val.int <- rep(NA_real_, length(val))
val.int[val == "S"] <- 1
val.int[val == "I"] <- 2
@ -347,8 +347,8 @@ antimicrobials_equal <- function(y,
all(a == b, na.rm = TRUE)
}
}
out <- unlist(mapply(
FUN = determine_equality,
out <- unlist(Map(
f = determine_equality,
y,
z,
MoreArgs = list(
@ -356,7 +356,6 @@ antimicrobials_equal <- function(y,
points_threshold = points_threshold,
ignore_I = ignore_I
),
SIMPLIFY = FALSE,
USE.NAMES = FALSE
))
out[is.na(y) | is.na(z)] <- NA

5
R/like.R
View File

@ -102,14 +102,13 @@ like <- function(x, pattern, ignore.case = TRUE) {
)
}
unlist(
mapply(
FUN = grepl,
Map(
f = grepl,
x = x,
pattern = pattern,
fixed = fixed,
perl = !fixed,
MoreArgs = list(ignore.case = FALSE),
SIMPLIFY = FALSE,
USE.NAMES = FALSE
)
)

81
R/mdro.R
View File

@ -190,15 +190,13 @@ mdro <- function(x = NULL,
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
check_dataset_integrity()
info.bak <- info
# don't thrown info's more than once per call
if (isTRUE(info)) {
info <- message_not_thrown_before("mdro")
}
if (interactive() & verbose == TRUE & info == TRUE) {
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
txt <- paste0(
"WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
"\n\nThis may overwrite your existing data if you use e.g.:",
@ -217,7 +215,7 @@ mdro <- function(x = NULL,
}
group_msg <- ""
if (info.bak == TRUE) {
if (isTRUE(info.bak)) {
# print group name if used in dplyr::group_by()
cur_group <- import_fn("cur_group", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_group)) {
@ -255,7 +253,7 @@ mdro <- function(x = NULL,
if (is.list(guideline)) {
# Custom MDRO guideline ---------------------------------------------------
stop_ifnot(inherits(guideline, "custom_mdro_guideline"), "use `custom_mdro_guideline()` to create custom guidelines")
if (info == TRUE) {
if (isTRUE(info)) {
txt <- paste0(
"Determining MDROs based on custom rules",
ifelse(isTRUE(attributes(guideline)$as_factor),
@ -268,7 +266,7 @@ mdro <- function(x = NULL,
cat(txt, "\n", sep = "")
}
x <- run_custom_mdro_guideline(df = x, guideline = guideline, info = info)
if (info.bak == TRUE) {
if (isTRUE(info.bak)) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
cat(word_wrap(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the custom guideline"))))
@ -282,7 +280,7 @@ mdro <- function(x = NULL,
))))
}
}
if (verbose == TRUE) {
if (isTRUE(verbose)) {
return(x[, c(
"row_number",
"MDRO",
@ -319,7 +317,7 @@ mdro <- function(x = NULL,
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
}
if (is.null(col_mo) & guideline$code == "tb") {
if (is.null(col_mo) && guideline$code == "tb") {
message_(
"No column found as input for `col_mo`, ",
font_bold(paste0("assuming all rows contain ", font_italic("Mycobacterium tuberculosis"), "."))
@ -614,9 +612,9 @@ mdro <- function(x = NULL,
...
)
}
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available
if (info == TRUE) {
if (isTRUE(info)) {
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many EUCAST rules depend on it.")
}
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
@ -767,14 +765,14 @@ mdro <- function(x = NULL,
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
# nolint end
if (combine_SI == TRUE) {
if (isTRUE(combine_SI)) {
search_result <- "R"
} else {
search_result <- c("R", "I")
}
if (info == TRUE) {
if (combine_SI == TRUE) {
if (isTRUE(info)) {
if (isTRUE(combine_SI)) {
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
} else {
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
@ -819,7 +817,7 @@ mdro <- function(x = NULL,
trans_tbl <- function(to, rows, cols, any_all) {
cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)]
if (length(rows) > 0 & length(cols) > 0) {
if (length(rows) > 0 && length(cols) > 0) {
x[, cols] <- as.data.frame(lapply(
x[, cols, drop = FALSE],
function(col) as.rsi(col)
@ -836,7 +834,7 @@ mdro <- function(x = NULL,
function(y) y %in% search_result
)
paste(sort(c(
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ")),
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
names(cols_nonsus)[cols_nonsus]
)),
collapse = ", "
@ -871,7 +869,7 @@ mdro <- function(x = NULL,
}
trans_tbl2 <- function(txt, rows, lst) {
if (info == TRUE) {
if (isTRUE(info)) {
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
}
if (length(rows) > 0) {
@ -896,7 +894,7 @@ mdro <- function(x = NULL,
}
)
if (verbose == TRUE) {
if (isTRUE(verbose)) {
x[rows, "columns_nonsusceptible"] <<- vapply(
FUN.VALUE = character(1),
rows,
@ -929,7 +927,7 @@ mdro <- function(x = NULL,
x[which(row_filter), "classes_affected"] <<- 999
}
if (info == TRUE) {
if (isTRUE(info)) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
}
@ -951,21 +949,21 @@ mdro <- function(x = NULL,
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
# take amoxicillin if ampicillin is unavailable
if (is.na(AMP) & !is.na(AMX)) {
if (verbose == TRUE) {
if (is.na(AMP) && !is.na(AMX)) {
if (isTRUE(verbose)) {
message_("Filling ampicillin (AMP) results with amoxicillin (AMX) results")
}
AMP <- AMX
}
# take ceftriaxone if cefotaxime is unavailable and vice versa
if (is.na(CRO) & !is.na(CTX)) {
if (verbose == TRUE) {
if (is.na(CRO) && !is.na(CTX)) {
if (isTRUE(verbose)) {
message_("Filling ceftriaxone (CRO) results with cefotaxime (CTX) results")
}
CRO <- CTX
}
if (is.na(CTX) & !is.na(CRO)) {
if (verbose == TRUE) {
if (is.na(CTX) && !is.na(CRO)) {
if (isTRUE(verbose)) {
message_("Filling cefotaxime (CTX) results with ceftriaxone (CRO) results")
}
CTX <- CRO
@ -1156,7 +1154,7 @@ mdro <- function(x = NULL,
# now set MDROs:
# MDR (=2): >=3 classes affected
x[which(x$classes_affected >= 3), "MDRO"] <- 2
if (verbose == TRUE) {
if (isTRUE(verbose)) {
x[which(x$classes_affected >= 3), "reason"] <- paste0(
"at least 3 classes contain R",
ifelse(!isTRUE(combine_SI), " or I", ""), ": ",
@ -1167,7 +1165,7 @@ mdro <- function(x = NULL,
# XDR (=3): all but <=2 classes affected
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
if (verbose == TRUE) {
if (isTRUE(verbose)) {
x[which(x$MDRO == 3), "reason"] <- paste0(
"less than 3 classes remain susceptible (", x$classes_in_guideline[which((x$classes_in_guideline - x$classes_affected) <= 2)] - x$classes_affected[which(x$MDRO == 3)],
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)"
@ -1176,7 +1174,7 @@ mdro <- function(x = NULL,
# PDR (=4): all agents are R
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
if (verbose == TRUE) {
if (isTRUE(verbose)) {
x[which(x$MDRO == 4), "reason"] <- paste(
"all antibiotics in all",
x$classes_in_guideline[which(x$MDRO == 4)],
@ -1187,7 +1185,7 @@ mdro <- function(x = NULL,
# not enough classes available
x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
if (verbose == TRUE) {
if (isTRUE(verbose)) {
x[which(x$MDRO == -1), "reason"] <- paste0(
"not enough classes available: ", x$classes_available[which(x$MDRO == -1)],
" of required ", (floor(x$classes_in_guideline * pct_required_classes))[which(x$MDRO == -1)],
@ -1615,10 +1613,10 @@ mdro <- function(x = NULL,
"all"
)
if (!ab_missing(MEM) & !ab_missing(IPM) &
!ab_missing(GEN) & !ab_missing(TOB) &
!ab_missing(CIP) &
!ab_missing(CAZ) &
if (!ab_missing(MEM) && !ab_missing(IPM) &&
!ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) &&
!ab_missing(CAZ) &&
!ab_missing(TZP)) {
x$psae <- 0
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
@ -1666,7 +1664,7 @@ mdro <- function(x = NULL,
prepare_drug <- function(ab) {
# returns vector values of drug
# if `ab` is a column name, looks up the values in `x`
if (length(ab) == 1 & is.character(ab)) {
if (length(ab) == 1 && is.character(ab)) {
if (ab %in% colnames(x)) {
ab <- x[, ab, drop = TRUE]
}
@ -1727,7 +1725,7 @@ mdro <- function(x = NULL,
}
# some more info on negative results
if (verbose == TRUE) {
if (isTRUE(verbose)) {
if (guideline$code == "cmi2012") {
x[which(x$MDRO == 1 & !is.na(x$classes_affected)), "reason"] <- paste0(
x$classes_affected[which(x$MDRO == 1 & !is.na(x$classes_affected))],
@ -1742,14 +1740,14 @@ mdro <- function(x = NULL,
}
}
if (info.bak == TRUE) {
if (isTRUE(info.bak)) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
cat(font_bold(paste0("=> Found 0 MDROs since no isolates are covered by the guideline")))
} else {
cat(font_bold(paste0(
"=> Found ", sum(x$MDRO %in% c(2:5), na.rm = TRUE), " ", guideline$type, " out of ", sum(!is.na(x$MDRO)),
" isolates (", trimws(percentage(sum(x$MDRO %in% c(2:5), na.rm = TRUE) / sum(!is.na(x$MDRO)))), ")"
"=> Found ", sum(x$MDRO %in% 2:5, na.rm = TRUE), " ", guideline$type, " out of ", sum(!is.na(x$MDRO)),
" isolates (", trimws(percentage(sum(x$MDRO %in% 2:5, na.rm = TRUE) / sum(!is.na(x$MDRO)))), ")"
)))
}
}
@ -1819,7 +1817,7 @@ mdro <- function(x = NULL,
)
}
if (verbose == TRUE) {
if (isTRUE(verbose)) {
colnames(x)[colnames(x) == col_mo] <- "microorganism"
x$microorganism <- mo_name(x$microorganism, language = NULL)
x[, c(
@ -1974,7 +1972,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
new_mdros <- which(qry == TRUE & out == "")
if (info == TRUE) {
if (isTRUE(info)) {
cat(word_wrap(
"- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
"` (", length(new_mdros), " rows matched)"
@ -1982,7 +1980,10 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
}
val <- guideline[[i]]$value
out[new_mdros] <- val
reasons[new_mdros] <- paste0("matched rule ", gsub("rule", "", names(guideline)[i]), ": ", as.character(guideline[[i]]$query))
reasons[new_mdros] <- paste0(
"matched rule ",
gsub("rule", "", names(guideline)[i], fixed = TRUE), ": ", as.character(guideline[[i]]$query)
)
}
out[out == ""] <- "Negative"
reasons[out == "Negative"] <- "no rules matched"

2017
R/mo.R
View File

File diff suppressed because it is too large Load Diff

38
R/mo_matching_score.R
View File

@ -43,13 +43,17 @@
#' * \ifelse{html}{\out{<i>p<sub>n</sub></i> is the human pathogenic prevalence group of <i>n</i>, as described below;}}{p_n is the human pathogenic prevalence group of \eqn{n}, as described below;}
#' * \ifelse{html}{\out{<i>k<sub>n</sub></i> is the taxonomic kingdom of <i>n</i>, set as Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5.}}{l_n is the taxonomic kingdom of \eqn{n}, set as Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5.}
#'
#' The grouping into human pathogenic prevalence (\eqn{p}) is based on experience from several microbiological laboratories in the Netherlands in conjunction with international reports on pathogen prevalence. **Group 1** (most prevalent microorganisms) consists of all microorganisms where the taxonomic class is Gammaproteobacteria or where the taxonomic genus is *Enterococcus*, *Staphylococcus* or *Streptococcus*. This group consequently contains all common Gram-negative bacteria, such as *Pseudomonas* and *Legionella* and all species within the order Enterobacterales. **Group 2** consists of all microorganisms where the taxonomic phylum is Proteobacteria, Firmicutes, Actinobacteria or Sarcomastigophora, or where the taxonomic genus is *Absidia*, *Acremonium*, *Actinotignum*, *Alternaria*, *Anaerosalibacter*, *Apophysomyces*, *Arachnia*, *Aspergillus*, *Aureobacterium*, *Aureobasidium*, *Bacteroides*, *Basidiobolus*, *Beauveria*, *Blastocystis*, *Branhamella*, *Calymmatobacterium*, *Candida*, *Capnocytophaga*, *Catabacter*, *Chaetomium*, *Chryseobacterium*, *Chryseomonas*, *Chrysonilia*, *Cladophialophora*, *Cladosporium*, *Conidiobolus*, *Cryptococcus*, *Curvularia*, *Exophiala*, *Exserohilum*, *Flavobacterium*, *Fonsecaea*, *Fusarium*, *Fusobacterium*, *Hendersonula*, *Hypomyces*, *Koserella*, *Lelliottia*, *Leptosphaeria*, *Leptotrichia*, *Malassezia*, *Malbranchea*, *Mortierella*, *Mucor*, *Mycocentrospora*, *Mycoplasma*, *Nectria*, *Ochroconis*, *Oidiodendron*, *Phoma*, *Piedraia*, *Pithomyces*, *Pityrosporum*, *Prevotella*, *Pseudallescheria*, *Rhizomucor*, *Rhizopus*, *Rhodotorula*, *Scolecobasidium*, *Scopulariopsis*, *Scytalidium*, *Sporobolomyces*, *Stachybotrys*, *Stomatococcus*, *Treponema*, *Trichoderma*, *Trichophyton*, *Trichosporon*, *Tritirachium* or *Ureaplasma*. **Group 3** consists of all other microorganisms.
#' The grouping into human pathogenic prevalence (\eqn{p}) is based on experience from several microbiological laboratories in the Netherlands in conjunction with international reports on pathogen prevalence:
#'
#' **Group 1** (most prevalent microorganisms) consists of all microorganisms where the taxonomic class is Gammaproteobacteria or where the taxonomic genus is *Enterococcus*, *Staphylococcus* or *Streptococcus*. This group consequently contains all common Gram-negative bacteria, such as *Pseudomonas* and *Legionella* and all species within the order Enterobacterales.
#'
#' **Group 2** consists of all microorganisms where the taxonomic phylum is Proteobacteria, Firmicutes, Actinobacteria or Sarcomastigophora, or where the taxonomic genus is `r vector_or(MO_PREVALENT_GENERA, quotes = "*")`.
#'
#' **Group 3** consists of all other microorganisms.
#'
#' All characters in \eqn{x} and \eqn{n} are ignored that are other than A-Z, a-z, 0-9, spaces and parentheses.
#'
#' All matches are sorted descending on their matching score and for all user input values, the top match will be returned. This will lead to the effect that e.g., `"E. coli"` will return the microbial ID of *Escherichia coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Escherichia coli"), 3)`}, a highly prevalent microorganism found in humans) and not *Entamoeba coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Entamoeba coli"), 3)`}, a less prevalent microorganism in humans), although the latter would alphabetically come first.
#'
#' Since `AMR` version 1.8.1, common microorganism abbreviations are ignored in determining the matching score. These abbreviations are currently: `r vector_and(pkg_env$mo_field_abbreviations, quotes = FALSE)`.
#' @export
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
@ -68,16 +72,6 @@ mo_matching_score <- function(x, n) {
# no dots and other non-whitespace characters
x <- gsub("[^a-zA-Z0-9 \\(\\)]+", "", x)
# remove abbreviations known to the field
x <- gsub(paste0(
"(^|[^a-z0-9]+)(",
paste0(pkg_env$mo_field_abbreviations, collapse = "|"),
")([^a-z0-9]+|$)"
),
"", x,
perl = TRUE, ignore.case = TRUE
)
# only keep one space
x <- gsub(" +", " ", x)
@ -93,12 +87,18 @@ mo_matching_score <- function(x, n) {
l_n <- nchar(n)
lev <- double(length = length(x))
l_n.lev <- double(length = length(x))
for (i in seq_len(length(x))) {
# determine Levenshtein distance, but maximise to nchar of n
lev[i] <- utils::adist(x[i], n[i], ignore.case = FALSE, fixed = TRUE, costs = c(ins = 1, del = 1, sub = 1))
# minimum of (l_n, Levenshtein distance)
l_n.lev[i] <- min(l_n[i], as.double(lev[i]))
}
lev <- unlist(Map(
f = utils::adist,
x,
n,
ignore.case = FALSE,
USE.NAMES = FALSE,
fixed = TRUE
))
l_n.lev[l_n < lev] <- l_n[l_n < lev]
l_n.lev[lev < l_n] <- lev[lev < l_n]
l_n.lev[lev == l_n] <- lev[lev == l_n]
# human pathogenic prevalence (1 to 3), see ?as.mo
p_n <- MO_lookup[match(n, MO_lookup$fullname), "prevalence", drop = TRUE]
# kingdom index (Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5)

154
R/mo_property.R
View File

@ -32,7 +32,7 @@
#' @param ... other arguments passed on to [as.mo()], such as 'allow_uncertain' and 'ignore_pattern'
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param open browse the URL using [`browseURL()`][utils::browseURL()]
#' @details All functions will return the most recently known taxonomic property according to the Catalogue of Life, except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
#' @details All functions will return the most recently known taxonomic property [as included in this package][microorganisms], except for [mo_ref()], [mo_authors()] and [mo_year()]. Please refer to this example, knowing that *Escherichia blattae* was renamed to *Shimwellia blattae* in 2010:
#' - `mo_name("Escherichia blattae")` will return `"Shimwellia blattae"` (with a message about the renaming)
#' - `mo_ref("Escherichia blattae")` will return `"Burgess et al., 1973"` (with a message about the renaming)
#' - `mo_ref("Shimwellia blattae")` will return `"Priest et al., 2010"` (without a message)
@ -51,9 +51,8 @@
#'
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
#'
#' SNOMED codes - [mo_snomed()] - are from the `r SNOMED_VERSION$current_source`. See *Source* and the [microorganisms] data set for more info.
#' SNOMED codes - [mo_snomed()] - are from the version of `r documentation_date(TAXONOMY_VERSION$SNOMED$accessed_date)`. See *Source* and the [microorganisms] data set for more info.
#' @inheritSection mo_matching_score Matching Score for Microorganisms
#' @inheritSection catalogue_of_life Catalogue of Life
#' @inheritSection as.mo Source
#' @rdname mo_property
#' @name mo_property
@ -175,7 +174,7 @@ mo_name <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_name")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "fullname", language = language, ...),
language = language,
@ -196,7 +195,7 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_shortname")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
@ -236,7 +235,7 @@ mo_subspecies <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_subspecies")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
}
@ -249,7 +248,7 @@ mo_species <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_species")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
}
@ -262,7 +261,7 @@ mo_genus <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_genus")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
}
@ -275,7 +274,7 @@ mo_family <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_family")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
}
@ -288,7 +287,7 @@ mo_order <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_order")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
}
@ -301,7 +300,7 @@ mo_class <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_class")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
}
@ -314,7 +313,7 @@ mo_phylum <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_phylum")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
}
@ -327,7 +326,7 @@ mo_kingdom <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_kingdom")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
}
@ -344,7 +343,7 @@ mo_type <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_type")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
out <- mo_kingdom(x.mo, language = NULL)
@ -360,24 +359,26 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_gramstain")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
# keep_synonyms = TRUE to prevent messages - they won't change Gram stain anyway
x.mo <- as.mo(x, language = language, keep_synonyms = TRUE, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x <- rep(NA_character_, length(x))
# make all bacteria Gram negative
x[mo_kingdom(x.mo) == "Bacteria"] <- "Gram-negative"
x[mo_kingdom(x.mo, language = NULL, keep_synonyms = TRUE) == "Bacteria"] <- "Gram-negative"
# overwrite these 4 phyla with Gram-positives
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 (Cavalier-Smith, 2002)
x[(mo_phylum(x.mo) %in% c(
x[(mo_phylum(x.mo, language = NULL, keep_synonyms = TRUE) %in% c(
"Actinobacteria",
"Chloroflexi",
"Firmicutes",
"Tenericutes"
"Tenericutes",
"Bacillota" # this one is new! It was renamed from Firmicutes by Gibbons et al., 2021
) &
# but class Negativicutes (of phylum Firmicutes) are Gram-negative!
mo_class(x.mo) != "Negativicutes")
mo_class(x.mo, language = NULL, keep_synonyms = TRUE) != "Negativicutes")
# and of course our own ID for Gram-positives
| x.mo == "B_GRAMP"] <- "Gram-positive"
@ -393,7 +394,7 @@ mo_is_gram_negative <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_is_gram_negative")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@ -412,7 +413,7 @@ mo_is_gram_positive <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_is_gram_positive")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@ -431,7 +432,7 @@ mo_is_yeast <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_is_yeast")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@ -456,7 +457,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(ab, allow_NA = FALSE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- as.mo(x, language = language, ...)
ab <- as.ab(ab, language = NULL, flag_multiple_results = FALSE, info = FALSE)
@ -491,7 +492,7 @@ mo_snomed <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_snomed")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
mo_validate(x = x, property = "snomed", language = language, ...)
}
@ -504,7 +505,7 @@ mo_ref <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_ref")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
mo_validate(x = x, property = "ref", language = language, ...)
}
@ -517,7 +518,7 @@ mo_authors <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_authors")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# remove last 4 digits and presumably the comma and space that preceed them
@ -533,7 +534,7 @@ mo_year <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_year")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# get last 4 digits
@ -549,7 +550,7 @@ mo_lpsn <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_rank")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
mo_validate(x = x, property = "species_id", language = language, ...)
}
@ -562,7 +563,7 @@ mo_rank <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_rank")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
mo_validate(x = x, property = "rank", language = language, ...)
}
@ -575,7 +576,7 @@ mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_taxonomy")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@ -603,20 +604,22 @@ mo_synonyms <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_synonyms")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- as.mo(x, language = language, ...)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname", drop = TRUE])
if (length(res) == 0) {
syns <- lapply(x.mo, function(y) {
gbif <- AMR::microorganisms$gbif[match(y, AMR::microorganisms$mo)]
lpsn <- AMR::microorganisms$lpsn[match(y, AMR::microorganisms$mo)]
out <- AMR::microorganisms[which(AMR::microorganisms$lpsn_renamed_to %in% c(gbif, lpsn)), "fullname", drop = TRUE]
if (length(out) == 0) {
NULL
} else {
res
out
}
})
if (length(syns) > 1) {
names(syns) <- mo_name(x)
result <- syns
@ -636,7 +639,7 @@ mo_info <- function(x, language = get_AMR_locale(), ...) {
x <- find_mo_col(fn = "mo_info")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@ -673,21 +676,23 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
stop("FIX mo_url")
x.mo <- as.mo(x = x, language = language, ... = ...)
metadata <- get_mo_failures_uncertainties_renamed()
df <- microorganisms[match(x.mo, microorganisms$mo), c("mo", "fullname", "source", "kingdom", "rank"), drop = FALSE]
df$url <- ifelse(df$source == "LPSN",
paste0(CATALOGUE_OF_LIFE$url_LPSN, "/species/", gsub(" ", "-", tolower(df$fullname), fixed = TRUE)),
paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE))
)
genera <- which(df$kingdom == "Bacteria" & df$rank == "genus")
df$url[genera] <- gsub("/species/", "/genus/", df$url[genera], fixed = TRUE)
subsp <- which(df$kingdom == "Bacteria" & df$rank %in% c("subsp.", "infraspecies"))
df$url[subsp] <- gsub("/species/", "/subspecies/", df$url[subsp], fixed = TRUE)
#
# df <- AMR::microorganisms[match(x.mo, AMR::microorganisms$mo), c("mo", "fullname", "source", "kingdom", "rank"), drop = FALSE]
# df$url <- ifelse(df$source == "LPSN",
# paste0(CATALOGUE_OF_LIFE$url_LPSN, "/species/", gsub(" ", "-", tolower(df$fullname), fixed = TRUE)),
# paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE))
# )
#
# genera <- which(df$kingdom == "Bacteria" & df$rank == "genus")
# df$url[genera] <- gsub("/species/", "/genus/", df$url[genera], fixed = TRUE)
# subsp <- which(df$kingdom == "Bacteria" & df$rank %in% c("subsp.", "infraspecies"))
# df$url[subsp] <- gsub("/species/", "/subspecies/", df$url[subsp], fixed = TRUE)
u <- df$url
names(u) <- df$fullname
@ -712,48 +717,51 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), .
x <- find_mo_col(fn = "mo_property")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(AMR::microorganisms))
language <- validate_language(language)
translate_into_language(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
}
mo_validate <- function(x, property, language, ...) {
check_dataset_integrity()
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AMR::microorganisms[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE)
)
dots <- list(...)
Becker <- dots$Becker
if (is.null(Becker) | property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
if (is.null(Becker) || property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
Becker <- FALSE
}
Lancefield <- dots$Lancefield
if (is.null(Lancefield) | property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
if (is.null(Lancefield) || property %in% c("kingdom", "phylum", "class", "order", "family", "genus")) {
Lancefield <- FALSE
}
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") | Lancefield %in% c(TRUE, "all")
keep_synonyms <- dots$keep_synonyms
has_Becker_or_Lancefield_or_synonyms <- !isFALSE(keep_synonyms) || Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & !has_Becker_or_Lancefield, error = function(e) FALSE)) {
# special case for mo_* functions where class is already <mo>
x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
if (all(x %in% AMR::microorganisms$mo, na.rm = TRUE) && !has_Becker_or_Lancefield_or_synonyms) {
# do nothing, just don't run the other if-else's
} else if (all(x %in% AMR::microorganisms[[property]], na.rm = TRUE) && !has_Becker_or_Lancefield_or_synonyms) {
# no need to do anything, just return it
return(x)
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x[!is.na(x)] %in% MO_lookup[, property, drop = TRUE]) | has_Becker_or_Lancefield) {
x <- exec_as.mo(x, property = property, language = language, ...)
}
x <- as.mo(x, language = language, ...)
}
# get property reeaaally fast using match()
x <- microorganisms[[property]][match(x, microorganisms$mo)]
if (property == "mo") {
return(set_clean_class(x, new_class = c("mo", "character")))
} else if (property == "species_id") {
return(as.double(x))
} else if (property == "snomed") {
return(as.double(eval(parse(text = x))))
return(sort(as.character(eval(parse(text = x)))))
} else {
return(x)
# everything else is character
return(as.character(x))
}
}

16
R/mo_source.R
View File

@ -127,7 +127,7 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
mo_source_destination <- path.expand(destination)
stop_ifnot(interactive(), "this function can only be used in interactive mode, since it must ask for the user's permission to write a file to their home folder.")
stop_ifnot(interactive(), "this function can only be used in interactive mode, since it must ask for the user's permission to write a file to their file system.")
if (is.null(path) || path %in% c(FALSE, "")) {
pkg_env$mo_source <- NULL
@ -204,14 +204,14 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
word_wrap(paste0(
"This will write create the new file '",
mo_source_destination,
"', for which your permission is needed."
"', for which your permission is required."
)),
"\n\n",
word_wrap("Do you agree that this file will be created?")
)
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Create new file in home directory", txt)
q_continue <- showQuestion("Create new file", txt)
} else {
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
}
@ -257,8 +257,6 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
}
check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
check_dataset_integrity()
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}
@ -286,9 +284,9 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
return(FALSE)
}
}
if (!all(x$mo %in% c("", microorganisms$mo, microorganisms$fullname), na.rm = TRUE)) {
if (!all(x$mo %in% c("", AMR::microorganisms$mo, AMR::microorganisms$fullname), na.rm = TRUE)) {
if (stop_on_error == TRUE) {
invalid <- x[which(!x$mo %in% c("", microorganisms$mo, microorganisms$fullname)), , drop = FALSE]
invalid <- x[which(!x$mo %in% c("", AMR::microorganisms$mo, AMR::microorganisms$fullname)), , drop = FALSE]
if (nrow(invalid) > 1) {
plural <- "s"
} else {
@ -303,14 +301,14 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
return(FALSE)
}
}
if (colnames(x)[1] != "mo" & nrow(x) > length(unique(x[, 1, drop = 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 (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 {

2
R/pca.R
View File

@ -97,7 +97,7 @@ pca <- function(x,
error = function(e) stop(e$message, call. = FALSE)
)
if (length(new_list[[i]]) == 1) {
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
if (is.character(new_list[[i]]) && new_list[[i]] %in% colnames(x)) {
# this is to support quoted variables: df %pm>% pca("mycol1", "mycol2")
new_list[[i]] <- x[, new_list[[i]]]
} else {

14
R/plot.R
View File

@ -97,7 +97,7 @@ plot.mic <- function(x,
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -188,7 +188,7 @@ barplot.mic <- function(height,
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -236,7 +236,7 @@ autoplot.mic <- function(object,
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -336,7 +336,7 @@ plot.disk <- function(x,
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -427,7 +427,7 @@ barplot.disk <- function(height,
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -475,7 +475,7 @@ autoplot.disk <- function(object,
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
@ -639,7 +639,7 @@ barplot.rsi <- function(height,
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set

1
R/random.R
View File

@ -87,7 +87,6 @@ random_rsi <- function(size = NULL, prob_RSI = c(0.33, 0.33, 0.33), ...) {
}
random_exec <- function(type, size, mo = NULL, ab = NULL) {
check_dataset_integrity()
df <- rsi_translation %pm>%
pm_filter(guideline %like% "EUCAST") %pm>%
pm_arrange(pm_desc(guideline)) %pm>%

22
R/resistance_predict.R
View File

@ -132,18 +132,6 @@ resistance_predict <- function(x,
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
dots.names <- names(dots)
if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == "tbl")]
}
if ("I_as_R" %in% dots.names) {
warning_("in `resistance_predict()`: I_as_R is deprecated - use I_as_S instead.")
}
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
@ -167,10 +155,10 @@ resistance_predict <- function(x,
df[, col_ab] <- droplevels(as.rsi(df[, col_ab, drop = TRUE]))
if (I_as_S == TRUE) {
# then I as S
df[, col_ab] <- gsub("I", "S", df[, col_ab, drop = TRUE])
df[, col_ab] <- gsub("I", "S", df[, col_ab, drop = TRUE], fixed = TRUE)
} else {
# then I as R
df[, col_ab] <- gsub("I", "R", df[, col_ab, drop = TRUE])
df[, col_ab] <- gsub("I", "R", df[, col_ab, drop = TRUE], fixed = TRUE)
}
df[, col_ab] <- ifelse(is.na(df[, col_ab, drop = TRUE]), 0, df[, col_ab, drop = TRUE])
@ -257,10 +245,10 @@ resistance_predict <- function(x,
df_prediction$se_max <- as.integer(df_prediction$se_max)
} else {
# se_max not above 1
df_prediction$se_max <- ifelse(df_prediction$se_max > 1, 1, df_prediction$se_max)
df_prediction$se_max <- pmin(df_prediction$se_max, 1)
}
# se_min not below 0
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
df_prediction$se_min <- pmax(df_prediction$se_min, 0)
df_observations <- data.frame(
year = df$year,
@ -279,7 +267,7 @@ resistance_predict <- function(x,
df_prediction$se_max <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_max)
}
df_prediction$value <- ifelse(df_prediction$value > 1, 1, ifelse(df_prediction$value < 0, 0, df_prediction$value))
df_prediction$value <- ifelse(df_prediction$value > 1, 1, pmax(df_prediction$value, 0))
df_prediction <- df_prediction[order(df_prediction$year), , drop = FALSE]
out <- as_original_data_class(df_prediction, class(x.bak))

6
R/rsi.R
View File

@ -986,9 +986,9 @@ pillar_shaft.rsi <- function(x, ...) {
# colours will anyway not work when has_colour() == FALSE,
# but then the indentation should also not be applied
out[is.na(x)] <- font_grey(" NA")
out[x == "R"] <- font_rsi_R_bg(font_black(" R "))
out[x == "S"] <- font_rsi_S_bg(font_black(" S "))
out[x == "I"] <- font_rsi_I_bg(font_black(" I "))
out[x == "R"] <- font_red_bg(" R ")
out[x == "S"] <- font_green_bg(" S ")
out[x == "I"] <- font_orange_bg(" I ")
}
create_pillar_column(out, align = "left", width = 5)
}

12
R/rsi_calc.R
View File

@ -72,7 +72,7 @@ rsi_calc <- function(...,
} else {
dots <- dots[2:length(dots)]
}
if (length(dots) == 0 | all(dots == "df")) {
if (length(dots) == 0 || all(dots == "df")) {
# for complete data.frames, like example_isolates %pm>% select(AMC, GEN) %pm>% proportion_S()
# and the old rsi function, which has "df" as name of the first argument
x <- dots_df
@ -137,12 +137,12 @@ rsi_calc <- function(...,
FUN = min
)
numerator <- sum(as.integer(y) %in% as.integer(ab_result), na.rm = TRUE)
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(any(is.na(y)))))
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
} else {
# may contain NAs in any column
other_values <- setdiff(c(NA, levels(ab_result)), ab_result)
numerator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE)))
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & any(is.na(y)))))
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & anyNA(y))))
}
} else {
# x is not a data.frame
@ -228,9 +228,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
meet_criteria(combine_SI, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(combine_SI_missing, allow_class = "logical", has_length = 1, .call_depth = 1)
check_dataset_integrity()
if (isTRUE(combine_IR) & isTRUE(combine_SI_missing)) {
if (isTRUE(combine_IR) && isTRUE(combine_SI_missing)) {
combine_SI <- FALSE
}
stop_if(isTRUE(combine_SI) & isTRUE(combine_IR), "either `combine_SI` or `combine_IR` can be TRUE, not both", call = -2)
@ -249,7 +247,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
data <- as.data.frame(data, stringsAsFactors = FALSE)
if (isTRUE(combine_SI) | isTRUE(combine_IR)) {
if (isTRUE(combine_SI) || isTRUE(combine_IR)) {
for (i in seq_len(ncol(data))) {
if (is.rsi(data[, i, drop = TRUE])) {
data[, i] <- as.character(data[, i, drop = TRUE])

BIN
R/sysdata.rda
View File

Binary file not shown.

85
R/translate.R
View File

@ -30,14 +30,28 @@
#' @param language language to choose. Use one of these supported language names or ISO-639-1 codes: `r paste0('"', sapply(LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]), '" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", ")`.
#' @details The currently `r length(LANGUAGES_SUPPORTED)` supported languages are `r vector_and(sapply(LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]), quotes = FALSE, sort = FALSE)`. All these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#'
#' **To silence language notes when this package loads** on a non-English operating system, please set the option `AMR_locale` in your `.Rprofile` file like this:
#'
#' ```r
#' # Open .Rprofile file
#' utils::file.edit("~/.Rprofile")
#'
#' # Add e.g. Italian support to that file using:
#' options(AMR_locale = "Italian")
#' # or using:
#' AMR::set_AMR_locale("Italian")
#'
#' # And save the file!
#' ```
#'
#' Please read about adding or updating a language in [our Wiki](https://github.com/msberends/AMR/wiki/).
#'
#' ## Changing the Default Language
#' The system language will be used at default (as returned by `Sys.getenv("LANG")` or, if `LANG` is not set, [`Sys.getlocale("LC_COLLATE")`][Sys.getlocale()]), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:
#'
#' 1. Setting the R option `AMR_locale`, either by using `set_AMR_locale()` or by running e.g. `options(AMR_locale = "de")`.
#' 1. Setting the R option `AMR_locale`, either by using e.g. `set_AMR_locale("German")` or by running e.g. `options(AMR_locale = "German")`.
#'
#' Note that setting an \R option only works in the same session. Save the command `options(AMR_locale = "(your language)")` to your `.Rprofile` file to apply it for every session.
#' Note that setting an \R option only works in the same session. Save the command `options(AMR_locale = "(your language)")` to your `.Rprofile` file to apply it for every session. Run `utils::file.edit("~/.Rprofile")` to edit your `.Rprofile` file.
#' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory.
#'
#' Thus, if the R option `AMR_locale` is set, the system variables `LANGUAGE` and `LANG` will be ignored.
@ -47,16 +61,22 @@
#' @examples
#' # Current settings (based on system language)
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus")
#' mo_name("Coagulase-negative Staphylococcus (CoNS)")
#'
#' # setting another language
#' set_AMR_locale("Greek")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus")
#'
#' set_AMR_locale("Spanish")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus")
#' mo_name("Coagulase-negative Staphylococcus (CoNS)")
#'
#' # setting yet another language
#' set_AMR_locale("Greek")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus (CoNS)")
#'
#' # setting yet another language
#' set_AMR_locale("Ukrainian")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus (CoNS)")
#'
#' # set_AMR_locale() understands endonyms, English exonyms, and ISO-639-1:
#' set_AMR_locale("Deutsch")
@ -87,7 +107,7 @@ get_AMR_locale <- function() {
message_(
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. Change this with `set_AMR_locale()`. ",
"This note will be shown once per session."
"This note will be shown once per session but can be silenced, see `?set_AMR_locale()`."
)
}
lang
@ -98,13 +118,21 @@ get_AMR_locale <- function() {
set_AMR_locale <- function(language) {
language <- validate_language(language)
options(AMR_locale = language)
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.")
if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) {
# show which language to use now
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.")
}
}
#' @rdname translate
#' @export
reset_AMR_locale <- function() {
options(AMR_locale = NULL)
if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) {
# show which language to use now
language <- suppressMessages(get_AMR_locale())
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.")
}
}
#' @rdname translate
@ -115,10 +143,10 @@ translate_AMR <- function(x, language = get_AMR_locale()) {
validate_language <- function(language, extra_txt = character(0)) {
if (trimws(tolower(language)) %in% c("en", "english", "", "false", NA)) {
if (isTRUE(trimws(tolower(language[1])) %in% c("en", "english", "", "false", NA)) || length(language) == 0) {
return("en")
}
lang <- find_language(language, fallback = FALSE)
lang <- find_language(language[1], fallback = FALSE)
stop_ifnot(length(lang) > 0 && lang %in% LANGUAGES_SUPPORTED,
"unsupported language for AMR package", extra_txt, ": \"", language, "\". Use one of these language names or ISO-639-1 codes: ",
paste0('"', vapply(FUN.VALUE = character(1), LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]),
@ -131,20 +159,20 @@ validate_language <- function(language, extra_txt = character(0)) {
}
find_language <- function(language, fallback = TRUE) {
language <- Map(function(l, n, check = language) {
grepl(paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = FALSE,
perl = TRUE,
useBytes = FALSE
)
},
LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED,
USE.NAMES = TRUE
language <- Map(LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED,
f = function(l, n, check = language) {
grepl(paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = TRUE,
perl = TRUE,
useBytes = FALSE
)
},
USE.NAMES = TRUE
)
language <- names(which(language == TRUE))
if (isTRUE(fallback) && length(language) == 0) {
@ -160,10 +188,7 @@ translate_into_language <- function(from,
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) {
if (is.null(language)) {
return(from)
}
if (language %in% c("en", "", NA)) {
if (is.null(language) || language[1] %in% c("en", "", NA)) {
return(from)
}

61
R/zzz.R
View File

@ -26,12 +26,18 @@
# set up package environment, used by numerous AMR functions
pkg_env <- new.env(hash = FALSE)
pkg_env$mo_failed <- character(0)
pkg_env$mo_field_abbreviations <- c(
"AIEC", "ATEC", "BORSA", "CRSM", "DAEC", "EAEC",
"EHEC", "EIEC", "EPEC", "ETEC", "GISA", "MRPA",
"MRSA", "MRSE", "MSSA", "MSSE", "NMEC", "PISP",
"PRSP", "STEC", "UPEC", "VISA", "VISP", "VRE",
"VRSA", "VRSP"
pkg_env$mo_uncertainties <- data.frame(
uncertainty = integer(0),
input = character(0),
fullname = character(0),
mo = character(0),
candidates = character(0),
stringsAsFactors = FALSE
)
pkg_env$mo_previously_coerced <- data.frame(
x = character(0),
mo = character(0),
stringsAsFactors = FALSE
)
pkg_env$rsi_interpretation_history <- data.frame(
datetime = Sys.time()[0],
@ -62,7 +68,7 @@ if (utf8_supported && !is_latex) {
pkg_env$info_icon <- "i"
}
.onLoad <- function(...) {
.onLoad <- function(lib, pkg) {
# Support for tibble headers (type_sum) and tibble columns content (pillar_shaft)
# without the need to depend on other packages. This was suggested by the
# developers of the vctrs package:
@ -135,7 +141,6 @@ if (utf8_supported && !is_latex) {
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
assign(x = "AB_lookup", value = create_AB_lookup(), envir = asNamespace("AMR"))
assign(x = "MO_lookup", value = create_MO_lookup(), envir = asNamespace("AMR"))
assign(x = "MO.old_lookup", value = create_MO.old_lookup(), envir = asNamespace("AMR"))
# for mo_is_intrinsic_resistant() - saves a lot of time when executed on this vector
assign(x = "INTRINSIC_R", value = create_intr_resistance(), envir = asNamespace("AMR"))
}
@ -157,30 +162,34 @@ create_MO_lookup <- function() {
# all the rest
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 5
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
if (length(MO_FULLNAME_LOWER) == nrow(MO_lookup)) {
MO_lookup$fullname_lower <- MO_FULLNAME_LOWER
} else {
MO_lookup$fullname_lower <- ""
warning("MO table updated - Run: source(\"data-raw/_pre_commit_hook.R\")", call. = FALSE)
}
# # use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
# if (length(MO_FULLNAME_LOWER) == nrow(MO_lookup)) {
# MO_lookup$fullname_lower <- MO_FULLNAME_LOWER
# } else {
# MO_lookup$fullname_lower <- ""
# warning("MO table updated - Run: source(\"data-raw/_pre_commit_hook.R\")", call. = FALSE)
# }
# add a column with only "e coli" like combinations
MO_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO_lookup$fullname_lower, perl = TRUE)
MO_lookup$fullname_lower <- create_MO_fullname_lower()
MO_lookup$full_first <- substr(MO_lookup$fullname_lower, 1, 1)
MO_lookup$species_first <- substr(MO_lookup$species, 1, 1)
# so arrange data on prevalence first, then kingdom, then full name
MO_lookup[order(MO_lookup$prevalence, MO_lookup$kingdom_index, MO_lookup$fullname_lower), , drop = FALSE]
}
create_MO.old_lookup <- function() {
MO.old_lookup <- AMR::microorganisms.old
MO.old_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", tolower(trimws(MO.old_lookup$fullname))))
# add a column with only "e coli"-like combinations
MO.old_lookup$g_species <- trimws(gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower))
# so arrange data on prevalence first, then full name
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower), , drop = FALSE]
create_MO_fullname_lower <- function() {
MO_lookup <- AMR::microorganisms
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(
MO_lookup$genus,
MO_lookup$species,
MO_lookup$subspecies
)))
ind <- MO_lookup$genus == "" | grepl("^[(]unknown ", MO_lookup$fullname, perl = TRUE)
MO_lookup[ind, "fullname_lower"] <- tolower(MO_lookup[ind, "fullname", drop = TRUE])
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
MO_lookup$fullname_lower
}
create_intr_resistance <- function() {