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

last unit tests fix?

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-10-04 21:33:04 +02:00
parent 37f6db5ccd
commit aa06aad4ea
22 changed files with 275 additions and 256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@ -1,5 +1,5 @@
Package: AMR Package: AMR
Version: 1.8.2.9027 Version: 1.8.2.9028
Date: 2022-10-04 Date: 2022-10-04
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)

5
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9027 # AMR 1.8.2.9028
This version will eventually become v2.0! We're happy to reach a new major milestone soon! This version will eventually become v2.0! We're happy to reach a new major milestone soon!
@ -9,11 +9,12 @@ This version will eventually become v2.0! We're happy to reach a new major miles
* Chromista are almost never clinically relevant, thus lacking the secondary scope of this package * Chromista are almost never clinically relevant, thus lacking the secondary scope of this package
* The `microorganisms` no longer relies on the Catalogue of Life, but now primarily on the List of Prokaryotic names with Standing in Nomenclature (LPSN) and is supplemented with the Global Biodiversity Information Facility (GBIF). The structure of this data set has changed to include separate LPSN and GBIF identifiers. Almost all previous MO codes were retained. It contains over 1,000 taxonomic names from 2022 already. * The `microorganisms` no longer relies on the Catalogue of Life, but now primarily on the List of Prokaryotic names with Standing in Nomenclature (LPSN) and is supplemented with the Global Biodiversity Information Facility (GBIF). The structure of this data set has changed to include separate LPSN and GBIF identifiers. Almost all previous MO codes were retained. It contains over 1,000 taxonomic names from 2022 already.
* The `microorganisms.old` data set was removed, and all previously accepted names are now included in the `microorganisms` data set. A new column `status` contains `"accepted"` for currently accepted names and `"synonym"` for taxonomic synonyms; currently invalid names. All previously accepted names now have a microorganisms ID and - if available - an LPSN, GBIF and SNOMED CT identifier. * The `microorganisms.old` data set was removed, and all previously accepted names are now included in the `microorganisms` data set. A new column `status` contains `"accepted"` for currently accepted names and `"synonym"` for taxonomic synonyms; currently invalid names. All previously accepted names now have a microorganisms ID and - if available - an LPSN, GBIF and SNOMED CT identifier.
* The `mo_matching_score()` now count deletions and substitutions as 2 instead of 1, which impacts the outcome of `as.mo()` and any `mo_*()` function
### New ### New
* EUCAST 2022 and CLSI 2022 guidelines have been added for `as.rsi()`. EUCAST 2022 is now the new default guideline for all MIC and disks diffusion interpretations. * EUCAST 2022 and CLSI 2022 guidelines have been added for `as.rsi()`. EUCAST 2022 is now the new default guideline for all MIC and disks diffusion interpretations.
* All new algorithm for `as.mo()` (and thus internally all `mo_*()` functions) while still following our original set-up as described in our paper (DOI 10.18637/jss.v104.i03). * All new algorithm for `as.mo()` (and thus internally all `mo_*()` functions) while still following our original set-up as described in our paper (DOI 10.18637/jss.v104.i03).
* A new argument `keep_synonyms` allows to *not* correct for updated taxonomy * A new argument `keep_synonyms` allows to *not* correct for updated taxonomy, in favour of the now deleted argument `allow_uncertain`
* It has increased tremendously in speed and returns generally more consequent results * It has increased tremendously in speed and returns generally more consequent results
* Sequential coercion is now extremely fast as results are stored to the package environment, although coercion of unknown values must be run once per session. Previous results can be reset/removed with the new `mo_reset_session()` function. * Sequential coercion is now extremely fast as results are stored to the package environment, although coercion of unknown values must be run once per session. Previous results can be reset/removed with the new `mo_reset_session()` function.
* Function `mean_amr_distance()` to calculate the mean AMR distance. The mean AMR distance is a normalised numeric value to compare AMR test results and can help to identify similar isolates, without comparing antibiograms by hand. * Function `mean_amr_distance()` to calculate the mean AMR distance. The mean AMR distance is a normalised numeric value to compare AMR test results and can help to identify similar isolates, without comparing antibiograms by hand.

158
R/aa_helper_functions.R
View File

@ -112,9 +112,9 @@ quick_case_when <- function(...) {
problems <- lhs_problems | rhs_problems problems <- lhs_problems | rhs_problems
if (any(problems)) { if (any(problems)) {
stop("The following formulas must be length ", len, " or 1, not ", stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ", paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "), paste(fs[problems], collapse = "\n "),
call. = FALSE call. = FALSE
) )
} }
} }
@ -181,12 +181,12 @@ addin_insert_like <- function() {
pos_preceded_by <- function(txt) { pos_preceded_by <- function(txt) {
if (tryCatch(substr(current_row_txt, current_col - nchar(trimws(txt, which = "right")), current_col) == trimws(txt, which = "right"), if (tryCatch(substr(current_row_txt, current_col - nchar(trimws(txt, which = "right")), current_col) == trimws(txt, which = "right"),
error = function(e) FALSE error = function(e) FALSE
)) { )) {
return(TRUE) return(TRUE)
} }
tryCatch(substr(current_row_txt, current_col - nchar(txt), current_col) %like% paste0("^", txt), tryCatch(substr(current_row_txt, current_col - nchar(txt), current_col) %like% paste0("^", txt),
error = function(e) FALSE error = function(e) FALSE
) )
} }
replace_pos <- function(old, with) { replace_pos <- function(old, with) {
@ -229,7 +229,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
# take first <mo> column # take first <mo> column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)] found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
} else if ("mo" %in% colnames_formatted && } else if ("mo" %in% colnames_formatted &&
suppressWarnings(all(x$mo %in% c(NA, AMR::microorganisms$mo)))) { suppressWarnings(all(x$mo %in% c(NA, AMR::microorganisms$mo)))) {
found <- "mo" found <- "mo"
} else if (any(colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) { } 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?$"]) found <- sort(colnames(x)[colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"])
@ -294,8 +294,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
# this column should contain logicals # this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) { if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `col_", type, message_("Column '", font_bold(found), "' found as input for `col_", type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.", "`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red add_fn = font_red
) )
found <- NULL found <- NULL
} }
@ -349,16 +349,16 @@ stop_ifnot_installed <- function(package) {
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html # https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
vapply(FUN.VALUE = character(1), package, function(pkg) { vapply(FUN.VALUE = character(1), package, function(pkg) {
tryCatch(get(".packageName", envir = asNamespace(pkg)), tryCatch(get(".packageName", envir = asNamespace(pkg)),
error = function(e) { error = function(e) {
if (pkg == "rstudioapi") { if (pkg == "rstudioapi") {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE) stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (pkg != "base") { } else if (pkg != "base") {
stop("This requires the '", pkg, "' package.", stop("This requires the '", pkg, "' package.",
"\nTry to install it with: install.packages(\"", pkg, "\")", "\nTry to install it with: install.packages(\"", pkg, "\")",
call. = FALSE call. = FALSE
) )
} }
} }
) )
}) })
return(invisible()) return(invisible())
@ -386,8 +386,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
error = function(e) { error = function(e) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_("function ", name, "() is not an exported object from package '", pkg, stop_("function ", name, "() is not an exported object from package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!", "'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE call = FALSE
) )
} else { } else {
return(NULL) return(NULL)
@ -434,13 +434,13 @@ word_wrap <- function(...,
msg_stripped <- font_stripstyle(msg) msg_stripped <- font_stripstyle(msg)
# where are the spaces now? # where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped, msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE, simplify = TRUE,
width = width width = width
), ),
collapse = "\n" collapse = "\n"
) )
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")), msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n" collapse = "\n"
) )
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ") msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n") msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
@ -490,8 +490,8 @@ message_ <- function(...,
add_fn = list(font_blue), add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message(word_wrap(..., message(word_wrap(...,
add_fn = add_fn, add_fn = add_fn,
as_note = as_note as_note = as_note
), ),
appendLF = appendLF appendLF = appendLF
) )
@ -502,8 +502,8 @@ warning_ <- function(...,
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning(word_wrap(..., warning(word_wrap(...,
add_fn = add_fn, add_fn = add_fn,
as_note = FALSE as_note = FALSE
), ),
immediate. = immediate, immediate. = immediate,
call. = call call. = call
@ -742,7 +742,7 @@ meet_criteria <- function(object,
# if object is missing, or another error: # if object is missing, or another error:
tryCatch(invisible(object), tryCatch(invisible(object),
error = function(e) AMR_env$meet_criteria_error_txt <- e$message error = function(e) AMR_env$meet_criteria_error_txt <- e$message
) )
if (!is.null(AMR_env$meet_criteria_error_txt)) { if (!is.null(AMR_env$meet_criteria_error_txt)) {
error_txt <- AMR_env$meet_criteria_error_txt error_txt <- AMR_env$meet_criteria_error_txt
@ -762,33 +762,33 @@ meet_criteria <- function(object,
if (!is.null(allow_class)) { if (!is.null(allow_class)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name, stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)), "` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)), ", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth call = call_depth
) )
# check data.frames for data # check data.frames for data
if (inherits(object, "data.frame")) { if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0), stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name, "the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ", "` must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")", paste(dim(object), collapse = "x"), ")",
call = call_depth call = call_depth
) )
} }
} }
if (!is.null(has_length)) { if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name, stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE), "be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object), ", not ", length(object),
call = call_depth call = call_depth
) )
} }
if (!is.null(looks_like)) { if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name, stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"", "resemble the regular expression \"", looks_like, "\"",
call = call_depth call = call_depth
) )
} }
if (!is.null(is_in)) { if (!is.null(is_in)) {
@ -797,44 +797,44 @@ meet_criteria <- function(object,
is_in <- tolower(is_in) is_in <- tolower(is_in)
} }
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name, "` ", stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name, "` ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ", "must be either ",
"must only contain values " "must only contain values "
), ),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))), vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""), ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_positive)) { if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero", "be a number higher than zero",
"all be numbers higher than zero" "all be numbers higher than zero"
), ),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_positive_or_zero)) { if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number", "be zero or a positive number",
"all be zero or numbers higher than zero" "all be zero or numbers higher than zero"
), ),
call = call_depth call = call_depth
) )
} }
if (isTRUE(is_finite)) { if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ", "` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number", "be a finite number",
"all be finite numbers" "all be finite numbers"
), ),
" (i.e. not be infinite)", " (i.e. not be infinite)",
call = call_depth call = call_depth
) )
} }
if (!is.null(contains_column_class)) { if (!is.null(contains_column_class)) {
@ -903,8 +903,8 @@ get_current_data <- function(arg_name, call) {
examples <- "" examples <- ""
} }
stop_("this function must be used inside a `dplyr` verb or `data.frame` call", stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
examples, examples,
call = call call = call
) )
} else { } else {
# mimic a base R error that the argument is missing # mimic a base R error that the argument is missing
@ -1310,8 +1310,8 @@ percentage <- function(x, digits = NULL, ...) {
function(y) ifelse(length(y) == 2, nchar(y[2]), 0) function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE) )), na.rm = TRUE)
max(min(max_places, max(min(max_places,
maximum, maximum,
na.rm = TRUE na.rm = TRUE
), ),
minimum, minimum,
na.rm = TRUE na.rm = TRUE
@ -1329,10 +1329,10 @@ percentage <- function(x, digits = NULL, ...) {
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%" # round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%"
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100, x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
scientific = FALSE, scientific = FALSE,
digits = max(1, digits), digits = max(1, digits),
nsmall = digits, nsmall = digits,
... ...
) )
x_formatted <- paste0(x_formatted, "%") x_formatted <- paste0(x_formatted, "%")
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_ x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
@ -1495,9 +1495,9 @@ if (getRversion() < "3.5.0") {
which <- match.arg(which) which <- match.arg(which)
mysub <- function(re, x) sub(re, "", x, perl = TRUE) mysub <- function(re, x) sub(re, "", x, perl = TRUE)
switch(which, switch(which,
left = mysub(paste0("^", whitespace, "+"), x), left = mysub(paste0("^", whitespace, "+"), x),
right = mysub(paste0(whitespace, "+$"), x), right = mysub(paste0(whitespace, "+$"), x),
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x)) both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
) )
} }
} }

4
R/ab_selectors.R
View File

@ -580,8 +580,8 @@ ab_select_exec <- function(function_name,
ab_group <- function_name ab_group <- function_name
} }
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE), examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
tolower = TRUE, tolower = TRUE,
language = NULL language = NULL
), ),
quotes = FALSE quotes = FALSE
), ")") ), ")")

99
R/mo.R
View File

@ -371,9 +371,11 @@ as.mo <- function(x,
gbif_matches[!gbif_matches %in% AMR::microorganisms$gbif] <- NA gbif_matches[!gbif_matches %in% AMR::microorganisms$gbif] <- NA
lpsn_matches <- AMR::microorganisms$lpsn_renamed_to[match(out, AMR::microorganisms$mo)] lpsn_matches <- AMR::microorganisms$lpsn_renamed_to[match(out, AMR::microorganisms$mo)]
lpsn_matches[!lpsn_matches %in% AMR::microorganisms$lpsn] <- NA lpsn_matches[!lpsn_matches %in% AMR::microorganisms$lpsn] <- NA
AMR_env$mo_renamed <- list(old = out[!is.na(gbif_matches) | !is.na(lpsn_matches)], AMR_env$mo_renamed <- list(
gbif_matches = gbif_matches[!is.na(gbif_matches) | !is.na(lpsn_matches)], old = out[!is.na(gbif_matches) | !is.na(lpsn_matches)],
lpsn_matches = lpsn_matches[!is.na(gbif_matches) | !is.na(lpsn_matches)]) gbif_matches = gbif_matches[!is.na(gbif_matches) | !is.na(lpsn_matches)],
lpsn_matches = lpsn_matches[!is.na(gbif_matches) | !is.na(lpsn_matches)]
)
if (isFALSE(keep_synonyms)) { if (isFALSE(keep_synonyms)) {
out[which(!is.na(gbif_matches))] <- AMR::microorganisms$mo[match(gbif_matches[which(!is.na(gbif_matches))], AMR::microorganisms$gbif)] out[which(!is.na(gbif_matches))] <- AMR::microorganisms$mo[match(gbif_matches[which(!is.na(gbif_matches))], AMR::microorganisms$gbif)]
out[which(!is.na(lpsn_matches))] <- AMR::microorganisms$mo[match(lpsn_matches[which(!is.na(lpsn_matches))], AMR::microorganisms$lpsn)] out[which(!is.na(lpsn_matches))] <- AMR::microorganisms$mo[match(lpsn_matches[which(!is.na(lpsn_matches))], AMR::microorganisms$lpsn)]
@ -475,11 +477,13 @@ mo_renamed <- function() {
ref_old <- AMR::microorganisms$ref[match(x$old, AMR::microorganisms$mo)] ref_old <- AMR::microorganisms$ref[match(x$old, AMR::microorganisms$mo)]
ref_new <- AMR::microorganisms$ref[match(x$new, AMR::microorganisms$mo)] ref_new <- AMR::microorganisms$ref[match(x$new, AMR::microorganisms$mo)]
df_renamed <- data.frame(old = mo_old, df_renamed <- data.frame(
new = mo_new, old = mo_old,
ref_old = ref_old, new = mo_new,
ref_new = ref_new, ref_old = ref_old,
stringsAsFactors = FALSE) ref_new = ref_new,
stringsAsFactors = FALSE
)
df_renamed <- unique(df_renamed) df_renamed <- unique(df_renamed)
df_renamed <- df_renamed[order(df_renamed$old), , drop = FALSE] df_renamed <- df_renamed[order(df_renamed$old), , drop = FALSE]
set_clean_class(df_renamed, new_class = c("mo_renamed", "data.frame")) set_clean_class(df_renamed, new_class = c("mo_renamed", "data.frame"))
@ -512,7 +516,8 @@ mo_cleaning_regex <- function() {
"|", "|",
"([({]|\\[).+([})]|\\])", "([({]|\\[).+([})]|\\])",
"|", "|",
"(^| )(e?spp|e?ssp|e?ss|e?sp|e?subsp|sube?species|biovar|biotype|serovar|e?species)[.]*( |$))") "(^| )(e?spp|e?ssp|e?ss|e?sp|e?subsp|sube?species|biovar|biotype|serovar|e?species)[.]*( |$))"
)
} }
# UNDOCUMENTED METHODS ---------------------------------------------------- # UNDOCUMENTED METHODS ----------------------------------------------------
@ -815,27 +820,30 @@ print.mo_uncertainties <- function(x, ...) {
) )
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3)) score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
txt <- paste(txt, txt <- paste(txt,
paste0( paste0(
paste0( paste0(
'"', x[i, ]$original_input, '"', '"', x[i, ]$original_input, '"',
" -> ", " -> ",
paste0( paste0(
font_bold(font_italic(x[i, ]$fullname)), font_bold(font_italic(x[i, ]$fullname)),
ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""), ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""),
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")" " (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
) )
), ),
collapse = "\n" collapse = "\n"
), ),
# Add "Based on {input}" text if it differs from the original input # Add "Based on {input}" text if it differs from the original input
ifelse(x[i, ]$original_input != x[i, ]$input, paste0(strrep(" ", nchar(x[i, ]$original_input) + 6), "Based on input \"", x[i, ]$input, "\""), ""), ifelse(x[i, ]$original_input != x[i, ]$input, paste0(strrep(" ", nchar(x[i, ]$original_input) + 6), "Based on input \"", x[i, ]$input, "\""), ""),
# Add note if result was coerced to accepted taxonomic name # Add note if result was coerced to accepted taxonomic name
ifelse(x[i, ]$keep_synonyms == FALSE & x[i, ]$mo %in% AMR::microorganisms$mo[which(AMR::microorganisms$status == "synonym")], ifelse(x[i, ]$keep_synonyms == FALSE & x[i, ]$mo %in% AMR::microorganisms$mo[which(AMR::microorganisms$status == "synonym")],
paste0(strrep(" ", nchar(x[i, ]$original_input) + 6), paste0(
font_red(paste0("This old taxonomic name was converted to ", font_italic(AMR::microorganisms$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR::microorganisms$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL)), strrep(" ", nchar(x[i, ]$original_input) + 6),
""), font_red(paste0("This old taxonomic name was converted to ", font_italic(AMR::microorganisms$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR::microorganisms$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL)
candidates, ),
sep = "\n" ""
),
candidates,
sep = "\n"
) )
txt <- paste0(gsub("\n\n", "\n", txt), "\n\n") txt <- paste0(gsub("\n\n", "\n", txt), "\n\n")
} }
@ -861,8 +869,8 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
message_( message_(
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n", "The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
paste0(" \u2022 ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows], paste0(" \u2022 ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows], " -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
collapse = "\n" collapse = "\n"
), ),
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "") ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "")
) )
@ -877,22 +885,26 @@ convert_colloquial_input <- function(x) {
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB) # Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
out[x %like_case% "^g[abcdfghkl]s$"] <- gsub("g([abcdfghkl])s", out[x %like_case% "^g[abcdfghkl]s$"] <- gsub("g([abcdfghkl])s",
"B_STRPT_GRP\\U\\1", "B_STRPT_GRP\\U\\1",
x[x %like_case% "^g[abcdfghkl]s$"], x[x %like_case% "^g[abcdfghkl]s$"],
perl = TRUE) perl = TRUE
)
# Streptococci in different languages, like "estreptococos grupo B" # Streptococci in different languages, like "estreptococos grupo B"
out[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdfghkl])$", out[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdfghkl])$",
"B_STRPT_GRP\\U\\1", "B_STRPT_GRP\\U\\1",
x[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"], x[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"],
perl = TRUE) perl = TRUE
)
out[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdfghkl]) strepto[ck]o[ck].*", out[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdfghkl]) strepto[ck]o[ck].*",
"B_STRPT_GRP\\U\\1", "B_STRPT_GRP\\U\\1",
x[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"], x[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"],
perl = TRUE) perl = TRUE
)
out[x %like_case% "ha?emoly.*strep"] <- "B_STRPT_HAEM" out[x %like_case% "ha?emoly.*strep"] <- "B_STRPT_HAEM"
out[x %like_case% "(strepto.* mil+er+i|^mgs[^a-z]*$)"] <- "B_STRPT_MILL" out[x %like_case% "(strepto.* mil+er+i|^mgs[^a-z]*$)"] <- "B_STRPT_MILL"
out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL" out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL"
out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI" out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) # CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
out[x %like_case% "([ck]oagulas[ea].negatie?[vf]|^[ck]o?ns[^a-z]*$)"] <- "B_STPHY_CONS" out[x %like_case% "([ck]oagulas[ea].negatie?[vf]|^[ck]o?ns[^a-z]*$)"] <- "B_STPHY_CONS"
@ -1087,6 +1099,7 @@ synonym_mo_to_accepted_mo <- function(x) {
x_lpsn[!x_lpsn %in% AMR::microorganisms$lpsn] <- NA x_lpsn[!x_lpsn %in% AMR::microorganisms$lpsn] <- NA
ifelse(is.na(x_lpsn), ifelse(is.na(x_lpsn),
AMR::microorganisms$mo[match(x_gbif, AMR::microorganisms$gbif)], AMR::microorganisms$mo[match(x_gbif, AMR::microorganisms$gbif)],
AMR::microorganisms$mo[match(x_lpsn, AMR::microorganisms$lpsn)]) AMR::microorganisms$mo[match(x_lpsn, AMR::microorganisms$lpsn)]
)
} }

11
R/mo_matching_score.R
View File

@ -80,7 +80,7 @@ mo_matching_score <- function(x, n) {
# only keep one space # only keep one space
x <- gsub(" +", " ", x) x <- gsub(" +", " ", x)
# start with a capital letter # force a capital letter, so this conversion will not count as a substitution
substr(x, 1, 1) <- toupper(substr(x, 1, 1)) substr(x, 1, 1) <- toupper(substr(x, 1, 1))
# n is always a taxonomically valid full name # n is always a taxonomically valid full name
@ -97,10 +97,11 @@ mo_matching_score <- function(x, n) {
l_n.lev <- double(length = length(x)) l_n.lev <- double(length = length(x))
lev <- unlist(Map(f = function(a, b) { lev <- unlist(Map(f = function(a, b) {
as.double(utils::adist(a, b, as.double(utils::adist(a, b,
ignore.case = FALSE, ignore.case = FALSE,
fixed = TRUE, fixed = TRUE,
costs = c(insertions = 1, deletions = 2, substitutions = 2), costs = c(insertions = 1, deletions = 2, substitutions = 2),
counts = FALSE)) counts = FALSE
))
}, x, n, USE.NAMES = FALSE)) }, x, n, USE.NAMES = FALSE))
l_n.lev[l_n < lev] <- l_n[l_n < lev] l_n.lev[l_n < lev] <- l_n[l_n < lev]

14
R/rsi.R
View File

@ -353,13 +353,13 @@ as.rsi.default <- function(x, ...) {
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.rsi()`: ", na_after - na_before, " result", warning_("in `as.rsi()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",
round(((na_after - na_before) / length(x)) * 100), round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ", "%) that were invalid antimicrobial interpretations: ",
list_missing, list_missing,
call = FALSE call = FALSE
) )
} }
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) { if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) {

BIN
R/sysdata.rda
View File

Binary file not shown.

13
R/translate.R
View File

@ -124,11 +124,14 @@ set_AMR_locale <- function(language) {
options(AMR_locale = language) options(AMR_locale = language)
if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) { if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) {
# show which language to use now # show which language to use now
message_("Using ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, message_(
ifelse(language != "en", "Using ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym,
paste0(" (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ")"), ifelse(language != "en",
""), paste0(" (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ")"),
" for the AMR package for this session.") ""
),
" for the AMR package for this session."
)
} }
} }

4
data-raw/_pre_commit_hook.R
View File

@ -104,7 +104,7 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
MO_staph[which(MO_staph$species %in% c( MO_staph[which(MO_staph$species %in% c(
"coagulase-negative", "argensis", "arlettae", "coagulase-negative", "argensis", "arlettae",
"auricularis", "borealis", "caeli", "capitis", "caprae", "auricularis", "borealis", "caeli", "capitis", "caprae",
"carnosus", "casei", "chromogenes", "cohnii", "condimenti", "carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
"croceilyticus", "croceilyticus",
"debuckii", "devriesei", "edaphicus", "epidermidis", "debuckii", "devriesei", "edaphicus", "epidermidis",
"equorum", "felis", "fleurettii", "gallinarum", "equorum", "felis", "fleurettii", "gallinarum",
@ -118,7 +118,7 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
"vitulinus", "vitulus", "warneri", "xylosus", "vitulinus", "vitulus", "warneri", "xylosus",
"caledonicus", "canis", "caledonicus", "canis",
"durrellii", "lloydii", "durrellii", "lloydii",
"ratti", "taiwanensis" "ratti", "taiwanensis", "veratri", "urealyticus"
) | ) |
# old, now renamed to S. schleiferi (but still as synonym in our data of course): # old, now renamed to S. schleiferi (but still as synonym in our data of course):
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))), (MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),

3
data-raw/reproduction_of_microorganisms.R
View File

@ -1016,7 +1016,8 @@ taxonomy <- taxonomy %>%
# Animalia: # Animalia:
!genus %in% c("Lucilia", "Lumbricus"), !genus %in% c("Lucilia", "Lumbricus"),
!(genus %in% c("Aedes", "Anopheles") & rank %in% c("species", "subspecies")), # only genus of the many hundreds of mosquitoes species !(genus %in% c("Aedes", "Anopheles") & rank %in% c("species", "subspecies")), # only genus of the many hundreds of mosquitoes species
kingdom != "Plantae") # this kingdom only contained Curvularia and Hymenolepis, which have coincidental twin names with Fungi kingdom != "Plantae"
) # this kingdom only contained Curvularia and Hymenolepis, which have coincidental twin names with Fungi
message("\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n") message("\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n")

11
inst/tinytest/test-data.R
View File

@ -68,10 +68,10 @@ df <- AMR:::MO_lookup
expect_true(nrow(df[which(df$prevalence == 1), , drop = FALSE]) < nrow(df[which(df$prevalence == 2), , drop = FALSE])) expect_true(nrow(df[which(df$prevalence == 1), , drop = FALSE]) < nrow(df[which(df$prevalence == 2), , drop = FALSE]))
expect_true(nrow(df[which(df$prevalence == 2), , drop = FALSE]) < nrow(df[which(df$prevalence == 3), , drop = FALSE])) expect_true(nrow(df[which(df$prevalence == 2), , drop = FALSE]) < nrow(df[which(df$prevalence == 3), , drop = FALSE]))
expect_true(all(c( expect_true(all(c(
"mo", "fullname", "mo", "fullname", "status", "kingdom", "phylum", "class", "order",
"kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies", "family", "genus", "species", "subspecies", "rank", "ref", "source",
"rank", "ref", "lpsn", "gbif", "status", "source", "prevalence", "snomed", "lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence",
"kingdom_index", "fullname_lower", "g_species" "snomed", "kingdom_index", "fullname_lower", "full_first", "species_first"
) %in% colnames(df))) ) %in% colnames(df)))
expect_inherits(AMR:::MO_CONS, "mo") expect_inherits(AMR:::MO_CONS, "mo")
@ -87,7 +87,8 @@ expect_true(NROW(uncategorised) == 0,
"All staphylococcal species categorised as CoNS/CoPS.", "All staphylococcal species categorised as CoNS/CoPS.",
paste0( paste0(
"Staphylococcal species not categorised as CoNS/CoPS: S. ", "Staphylococcal species not categorised as CoNS/CoPS: S. ",
uncategorised$species, " (", uncategorised$mo, ")" uncategorised$species, " (", uncategorised$mo, ")",
collapse = "\n"
) )
) )
) )

2
inst/tinytest/test-eucast_rules.R
View File

@ -41,7 +41,7 @@ expect_equal(
) )
MOs_mentioned <- unique(AMR:::EUCAST_RULES_DF$this_value) MOs_mentioned <- unique(AMR:::EUCAST_RULES_DF$this_value)
MOs_mentioned <- sort(trimws(unlist(strsplit(MOs_mentioned[!AMR:::is_valid_regex(MOs_mentioned)], ",", fixed = TRUE)))) MOs_mentioned <- sort(trimws(unlist(strsplit(MOs_mentioned[!AMR:::is_valid_regex(MOs_mentioned)], ",", fixed = TRUE))))
MOs_test <- suppressWarnings(suppressMessages(mo_name(MOs_mentioned))) MOs_test <- suppressWarnings(suppressMessages(mo_name(MOs_mentioned, keep_synonyms = TRUE, language = NULL)))
expect_true(length(MOs_mentioned[MOs_test != MOs_mentioned]) == 0) expect_true(length(MOs_mentioned[MOs_test != MOs_mentioned]) == 0)
expect_error(suppressWarnings(eucast_rules(example_isolates, col_mo = "Non-existing"))) expect_error(suppressWarnings(eucast_rules(example_isolates, col_mo = "Non-existing")))

12
inst/tinytest/test-mo_property.R
View File

@ -59,7 +59,7 @@ expect_inherits(mo_synonyms(c("Candida albicans", "Escherichia coli")), "list")
expect_equal(names(mo_info("Escherichia coli")), c( expect_equal(names(mo_info("Escherichia coli")), c(
"kingdom", "phylum", "class", "order", "kingdom", "phylum", "class", "order",
"family", "genus", "species", "subspecies", "family", "genus", "species", "subspecies",
"synonyms", "gramstain", "url", "ref", "status", "synonyms", "gramstain", "url", "ref",
"snomed" "snomed"
)) ))
expect_inherits(mo_info(c("Escherichia coli", "Staphylococcus aureus")), "list") expect_inherits(mo_info(c("Escherichia coli", "Staphylococcus aureus")), "list")
@ -73,7 +73,7 @@ expect_true(mo_url("Escherichia coli") %like% "lpsn.dsmz.de")
# test integrity # test integrity
MOs <- microorganisms MOs <- microorganisms
expect_identical(MOs$fullname, mo_fullname(MOs$fullname, language = "en")) expect_identical(MOs$fullname, mo_fullname(MOs$fullname, language = "en", keep_synonyms = TRUE))
# check languages # check languages
expect_equal(mo_type("Escherichia coli", language = "de"), "Bakterien") expect_equal(mo_type("Escherichia coli", language = "de"), "Bakterien")
@ -81,13 +81,13 @@ expect_equal(mo_gramstain("Escherichia coli", language = "nl"), "Gram-negatief")
gr <- mo_gramstain("Escherichia coli", language = NULL) gr <- mo_gramstain("Escherichia coli", language = NULL)
for (l in AMR:::LANGUAGES_SUPPORTED[-1]) { for (l in AMR:::LANGUAGES_SUPPORTED[-1]) {
expect_false(mo_gramstain("Escherichia coli", language = l) == gr, info = paste("Gram-stain in langauge", l)) expect_false(mo_gramstain("Escherichia coli", language = l) == gr, info = paste("Gram-stain in language", l))
} }
expect_error(mo_gramstain("Escherichia coli", language = "UNKNOWN")) expect_error(mo_gramstain("Escherichia coli", language = "UNKNOWN"))
dutch <- mo_name(microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase")], language = "nl") # should be transformable to English again dutch <- mo_name(microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase|Fungi")], language = "nl", keep_synonyms = TRUE) # should be transformable to English again
expect_identical(mo_name(dutch, language = NULL), expect_identical(mo_name(dutch, language = NULL, keep_synonyms = TRUE),
microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase")]) # gigantic test - will run ALL names microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase|Fungi")]) # gigantic test - will run ALL names
# manual property function # manual property function
expect_error(mo_property("Escherichia coli", property = c("genus", "fullname"))) expect_error(mo_property("Escherichia coli", property = c("genus", "fullname")))

1
tests/tinytest.R
View File

@ -76,4 +76,3 @@ if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
print(summary(out)) print(summary(out))
} }
} }