mirror of
https://github.com/msberends/AMR.git
synced 2025-01-15 23:21:37 +01:00
last unit tests fix?
This commit is contained in:
parent
37f6db5ccd
commit
aa06aad4ea
@ -1,5 +1,5 @@
|
||||
Package: AMR
|
||||
Version: 1.8.2.9027
|
||||
Version: 1.8.2.9028
|
||||
Date: 2022-10-04
|
||||
Title: Antimicrobial Resistance Data Analysis
|
||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||
|
||||
5
NEWS.md
5
NEWS.md
@ -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!
|
||||
|
||||
@ -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
|
||||
* 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 `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
|
||||
* 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).
|
||||
* 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
|
||||
* 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.
|
||||
|
||||
@ -112,9 +112,9 @@ quick_case_when <- function(...) {
|
||||
problems <- lhs_problems | rhs_problems
|
||||
if (any(problems)) {
|
||||
stop("The following formulas must be length ", len, " or 1, not ",
|
||||
paste(inconsistent_lengths, collapse = ", "), ".\n ",
|
||||
paste(fs[problems], collapse = "\n "),
|
||||
call. = FALSE
|
||||
paste(inconsistent_lengths, collapse = ", "), ".\n ",
|
||||
paste(fs[problems], collapse = "\n "),
|
||||
call. = FALSE
|
||||
)
|
||||
}
|
||||
}
|
||||
@ -181,12 +181,12 @@ addin_insert_like <- function() {
|
||||
|
||||
pos_preceded_by <- function(txt) {
|
||||
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)
|
||||
}
|
||||
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) {
|
||||
@ -229,7 +229,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
# 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, AMR::microorganisms$mo)))) {
|
||||
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?$"])
|
||||
@ -294,8 +294,8 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
# this column should contain logicals
|
||||
if (!is.logical(x[, found, drop = TRUE])) {
|
||||
message_("Column '", font_bold(found), "' found as input for `col_", type,
|
||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
|
||||
add_fn = font_red
|
||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
|
||||
add_fn = font_red
|
||||
)
|
||||
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
|
||||
vapply(FUN.VALUE = character(1), package, function(pkg) {
|
||||
tryCatch(get(".packageName", envir = asNamespace(pkg)),
|
||||
error = function(e) {
|
||||
if (pkg == "rstudioapi") {
|
||||
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
|
||||
} else if (pkg != "base") {
|
||||
stop("This requires the '", pkg, "' package.",
|
||||
"\nTry to install it with: install.packages(\"", pkg, "\")",
|
||||
call. = FALSE
|
||||
)
|
||||
}
|
||||
}
|
||||
error = function(e) {
|
||||
if (pkg == "rstudioapi") {
|
||||
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
|
||||
} else if (pkg != "base") {
|
||||
stop("This requires the '", pkg, "' package.",
|
||||
"\nTry to install it with: install.packages(\"", pkg, "\")",
|
||||
call. = FALSE
|
||||
)
|
||||
}
|
||||
}
|
||||
)
|
||||
})
|
||||
return(invisible())
|
||||
@ -386,8 +386,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
||||
error = function(e) {
|
||||
if (isTRUE(error_on_fail)) {
|
||||
stop_("function ", name, "() is not an exported object from package '", pkg,
|
||||
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
||||
call = FALSE
|
||||
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
||||
call = FALSE
|
||||
)
|
||||
} else {
|
||||
return(NULL)
|
||||
@ -434,13 +434,13 @@ word_wrap <- function(...,
|
||||
msg_stripped <- font_stripstyle(msg)
|
||||
# where are the spaces now?
|
||||
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
|
||||
simplify = TRUE,
|
||||
width = width
|
||||
simplify = TRUE,
|
||||
width = width
|
||||
),
|
||||
collapse = "\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_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
|
||||
@ -490,8 +490,8 @@ message_ <- function(...,
|
||||
add_fn = list(font_blue),
|
||||
as_note = TRUE) {
|
||||
message(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = as_note
|
||||
add_fn = add_fn,
|
||||
as_note = as_note
|
||||
),
|
||||
appendLF = appendLF
|
||||
)
|
||||
@ -502,8 +502,8 @@ warning_ <- function(...,
|
||||
immediate = FALSE,
|
||||
call = FALSE) {
|
||||
warning(word_wrap(...,
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE
|
||||
add_fn = add_fn,
|
||||
as_note = FALSE
|
||||
),
|
||||
immediate. = immediate,
|
||||
call. = call
|
||||
@ -742,7 +742,7 @@ meet_criteria <- function(object,
|
||||
|
||||
# if object is missing, or another error:
|
||||
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)) {
|
||||
error_txt <- AMR_env$meet_criteria_error_txt
|
||||
@ -762,33 +762,33 @@ meet_criteria <- function(object,
|
||||
|
||||
if (!is.null(allow_class)) {
|
||||
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
|
||||
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
|
||||
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
|
||||
call = call_depth
|
||||
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
|
||||
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
|
||||
call = call_depth
|
||||
)
|
||||
# check data.frames for data
|
||||
if (inherits(object, "data.frame")) {
|
||||
stop_if(any(dim(object) == 0),
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain rows and columns (current dimensions: ",
|
||||
paste(dim(object), collapse = "x"), ")",
|
||||
call = call_depth
|
||||
"the data provided in argument `", obj_name,
|
||||
"` must contain rows and columns (current dimensions: ",
|
||||
paste(dim(object), collapse = "x"), ")",
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
}
|
||||
if (!is.null(has_length)) {
|
||||
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"be of length ", vector_or(has_length, quotes = FALSE),
|
||||
", not ", length(object),
|
||||
call = call_depth
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"be of length ", vector_or(has_length, quotes = FALSE),
|
||||
", not ", length(object),
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (!is.null(looks_like)) {
|
||||
stop_ifnot(object %like% looks_like, "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"resemble the regular expression \"", looks_like, "\"",
|
||||
call = call_depth
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
"resemble the regular expression \"", looks_like, "\"",
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (!is.null(is_in)) {
|
||||
@ -797,44 +797,44 @@ meet_criteria <- function(object,
|
||||
is_in <- tolower(is_in)
|
||||
}
|
||||
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,
|
||||
"must be either ",
|
||||
"must only contain values "
|
||||
),
|
||||
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
|
||||
ifelse(allow_NA == TRUE, ", or NA", ""),
|
||||
call = call_depth
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"must be either ",
|
||||
"must only contain values "
|
||||
),
|
||||
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
|
||||
ifelse(allow_NA == TRUE, ", or NA", ""),
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (isTRUE(is_positive)) {
|
||||
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be a number higher than zero",
|
||||
"all be numbers higher than zero"
|
||||
),
|
||||
call = call_depth
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be a number higher than zero",
|
||||
"all be numbers higher than zero"
|
||||
),
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (isTRUE(is_positive_or_zero)) {
|
||||
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be zero or a positive number",
|
||||
"all be zero or numbers higher than zero"
|
||||
),
|
||||
call = call_depth
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be zero or a positive number",
|
||||
"all be zero or numbers higher than zero"
|
||||
),
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (isTRUE(is_finite)) {
|
||||
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be a finite number",
|
||||
"all be finite numbers"
|
||||
),
|
||||
" (i.e. not be infinite)",
|
||||
call = call_depth
|
||||
"` must ",
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be a finite number",
|
||||
"all be finite numbers"
|
||||
),
|
||||
" (i.e. not be infinite)",
|
||||
call = call_depth
|
||||
)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
@ -903,8 +903,8 @@ get_current_data <- function(arg_name, call) {
|
||||
examples <- ""
|
||||
}
|
||||
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
|
||||
examples,
|
||||
call = call
|
||||
examples,
|
||||
call = call
|
||||
)
|
||||
} else {
|
||||
# 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)
|
||||
)), na.rm = TRUE)
|
||||
max(min(max_places,
|
||||
maximum,
|
||||
na.rm = TRUE
|
||||
maximum,
|
||||
na.rm = TRUE
|
||||
),
|
||||
minimum,
|
||||
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%"
|
||||
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
|
||||
scientific = FALSE,
|
||||
digits = max(1, digits),
|
||||
nsmall = digits,
|
||||
...
|
||||
scientific = FALSE,
|
||||
digits = max(1, digits),
|
||||
nsmall = digits,
|
||||
...
|
||||
)
|
||||
x_formatted <- paste0(x_formatted, "%")
|
||||
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
|
||||
@ -1495,9 +1495,9 @@ if (getRversion() < "3.5.0") {
|
||||
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))
|
||||
left = mysub(paste0("^", whitespace, "+"), x),
|
||||
right = mysub(paste0(whitespace, "+$"), x),
|
||||
both = mysub(paste0(whitespace, "+$"), mysub(paste0("^", whitespace, "+"), x))
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
@ -580,8 +580,8 @@ ab_select_exec <- function(function_name,
|
||||
ab_group <- function_name
|
||||
}
|
||||
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
tolower = TRUE,
|
||||
language = NULL
|
||||
),
|
||||
quotes = FALSE
|
||||
), ")")
|
||||
|
||||
99
R/mo.R
99
R/mo.R
@ -371,9 +371,11 @@ as.mo <- function(x,
|
||||
gbif_matches[!gbif_matches %in% AMR::microorganisms$gbif] <- NA
|
||||
lpsn_matches <- AMR::microorganisms$lpsn_renamed_to[match(out, AMR::microorganisms$mo)]
|
||||
lpsn_matches[!lpsn_matches %in% AMR::microorganisms$lpsn] <- NA
|
||||
AMR_env$mo_renamed <- list(old = out[!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)])
|
||||
AMR_env$mo_renamed <- list(
|
||||
old = out[!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)) {
|
||||
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)]
|
||||
@ -475,11 +477,13 @@ mo_renamed <- function() {
|
||||
ref_old <- AMR::microorganisms$ref[match(x$old, AMR::microorganisms$mo)]
|
||||
ref_new <- AMR::microorganisms$ref[match(x$new, AMR::microorganisms$mo)]
|
||||
|
||||
df_renamed <- data.frame(old = mo_old,
|
||||
new = mo_new,
|
||||
ref_old = ref_old,
|
||||
ref_new = ref_new,
|
||||
stringsAsFactors = FALSE)
|
||||
df_renamed <- data.frame(
|
||||
old = mo_old,
|
||||
new = mo_new,
|
||||
ref_old = ref_old,
|
||||
ref_new = ref_new,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
df_renamed <- unique(df_renamed)
|
||||
df_renamed <- df_renamed[order(df_renamed$old), , drop = FALSE]
|
||||
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 ----------------------------------------------------
|
||||
@ -815,27 +820,30 @@ print.mo_uncertainties <- function(x, ...) {
|
||||
)
|
||||
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
||||
txt <- paste(txt,
|
||||
paste0(
|
||||
paste0(
|
||||
'"', x[i, ]$original_input, '"',
|
||||
" -> ",
|
||||
paste0(
|
||||
font_bold(font_italic(x[i, ]$fullname)),
|
||||
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), ")"
|
||||
)
|
||||
),
|
||||
collapse = "\n"
|
||||
),
|
||||
# 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, "\""), ""),
|
||||
# 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")],
|
||||
paste0(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"
|
||||
paste0(
|
||||
paste0(
|
||||
'"', x[i, ]$original_input, '"',
|
||||
" -> ",
|
||||
paste0(
|
||||
font_bold(font_italic(x[i, ]$fullname)),
|
||||
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), ")"
|
||||
)
|
||||
),
|
||||
collapse = "\n"
|
||||
),
|
||||
# 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, "\""), ""),
|
||||
# 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")],
|
||||
paste0(
|
||||
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"
|
||||
)
|
||||
txt <- paste0(gsub("\n\n", "\n", txt), "\n\n")
|
||||
}
|
||||
@ -861,8 +869,8 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
||||
message_(
|
||||
"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],
|
||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
||||
collapse = "\n"
|
||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
||||
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."), "")
|
||||
)
|
||||
@ -877,22 +885,26 @@ convert_colloquial_input <- function(x) {
|
||||
|
||||
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
|
||||
out[x %like_case% "^g[abcdfghkl]s$"] <- gsub("g([abcdfghkl])s",
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "^g[abcdfghkl]s$"],
|
||||
perl = TRUE)
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "^g[abcdfghkl]s$"],
|
||||
perl = TRUE
|
||||
)
|
||||
# Streptococci in different languages, like "estreptococos grupo B"
|
||||
out[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdfghkl])$",
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"],
|
||||
perl = TRUE)
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "strepto[ck]o[ck].* [abcdfghkl]$"],
|
||||
perl = TRUE
|
||||
)
|
||||
out[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdfghkl]) strepto[ck]o[ck].*",
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"],
|
||||
perl = TRUE)
|
||||
"B_STRPT_GRP\\U\\1",
|
||||
x[x %like_case% "group [abcdfghkl] strepto[ck]o[ck]"],
|
||||
perl = TRUE
|
||||
)
|
||||
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% "mil+er+i gr"] <- "B_STRPT_MILL"
|
||||
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)
|
||||
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
|
||||
|
||||
ifelse(is.na(x_lpsn),
|
||||
AMR::microorganisms$mo[match(x_gbif, AMR::microorganisms$gbif)],
|
||||
AMR::microorganisms$mo[match(x_lpsn, AMR::microorganisms$lpsn)])
|
||||
AMR::microorganisms$mo[match(x_gbif, AMR::microorganisms$gbif)],
|
||||
AMR::microorganisms$mo[match(x_lpsn, AMR::microorganisms$lpsn)]
|
||||
)
|
||||
}
|
||||
|
||||
@ -80,7 +80,7 @@ mo_matching_score <- function(x, n) {
|
||||
# only keep one space
|
||||
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))
|
||||
|
||||
# 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))
|
||||
lev <- unlist(Map(f = function(a, b) {
|
||||
as.double(utils::adist(a, b,
|
||||
ignore.case = FALSE,
|
||||
fixed = TRUE,
|
||||
costs = c(insertions = 1, deletions = 2, substitutions = 2),
|
||||
counts = FALSE))
|
||||
ignore.case = FALSE,
|
||||
fixed = TRUE,
|
||||
costs = c(insertions = 1, deletions = 2, substitutions = 2),
|
||||
counts = FALSE
|
||||
))
|
||||
}, x, n, USE.NAMES = FALSE))
|
||||
|
||||
l_n.lev[l_n < lev] <- l_n[l_n < lev]
|
||||
|
||||
14
R/rsi.R
14
R/rsi.R
@ -353,13 +353,13 @@ as.rsi.default <- function(x, ...) {
|
||||
vector_and(quotes = TRUE)
|
||||
cur_col <- get_current_column()
|
||||
warning_("in `as.rsi()`: ", na_after - na_before, " result",
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
ifelse(na_after - na_before > 1, "s", ""),
|
||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||
" truncated (",
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
"%) that were invalid antimicrobial interpretations: ",
|
||||
list_missing,
|
||||
call = FALSE
|
||||
)
|
||||
}
|
||||
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) {
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
@ -124,11 +124,14 @@ set_AMR_locale <- function(language) {
|
||||
options(AMR_locale = language)
|
||||
if (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true")) {
|
||||
# show which language to use now
|
||||
message_("Using ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym,
|
||||
ifelse(language != "en",
|
||||
paste0(" (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ")"),
|
||||
""),
|
||||
" for the AMR package for this session.")
|
||||
message_(
|
||||
"Using ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym,
|
||||
ifelse(language != "en",
|
||||
paste0(" (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ")"),
|
||||
""
|
||||
),
|
||||
" for the AMR package for this session."
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -104,7 +104,7 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
|
||||
MO_staph[which(MO_staph$species %in% c(
|
||||
"coagulase-negative", "argensis", "arlettae",
|
||||
"auricularis", "borealis", "caeli", "capitis", "caprae",
|
||||
"carnosus", "casei", "chromogenes", "cohnii", "condimenti",
|
||||
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
|
||||
"croceilyticus",
|
||||
"debuckii", "devriesei", "edaphicus", "epidermidis",
|
||||
"equorum", "felis", "fleurettii", "gallinarum",
|
||||
@ -118,7 +118,7 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
|
||||
"vitulinus", "vitulus", "warneri", "xylosus",
|
||||
"caledonicus", "canis",
|
||||
"durrellii", "lloydii",
|
||||
"ratti", "taiwanensis"
|
||||
"ratti", "taiwanensis", "veratri", "urealyticus"
|
||||
) |
|
||||
# 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", ""))),
|
||||
|
||||
@ -1016,7 +1016,8 @@ taxonomy <- taxonomy %>%
|
||||
# Animalia:
|
||||
!genus %in% c("Lucilia", "Lumbricus"),
|
||||
!(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")
|
||||
|
||||
|
||||
@ -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 == 2), , drop = FALSE]) < nrow(df[which(df$prevalence == 3), , drop = FALSE]))
|
||||
expect_true(all(c(
|
||||
"mo", "fullname",
|
||||
"kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies",
|
||||
"rank", "ref", "lpsn", "gbif", "status", "source", "prevalence", "snomed",
|
||||
"kingdom_index", "fullname_lower", "g_species"
|
||||
"mo", "fullname", "status", "kingdom", "phylum", "class", "order",
|
||||
"family", "genus", "species", "subspecies", "rank", "ref", "source",
|
||||
"lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence",
|
||||
"snomed", "kingdom_index", "fullname_lower", "full_first", "species_first"
|
||||
) %in% colnames(df)))
|
||||
|
||||
expect_inherits(AMR:::MO_CONS, "mo")
|
||||
@ -87,7 +87,8 @@ expect_true(NROW(uncategorised) == 0,
|
||||
"All staphylococcal species categorised as CoNS/CoPS.",
|
||||
paste0(
|
||||
"Staphylococcal species not categorised as CoNS/CoPS: S. ",
|
||||
uncategorised$species, " (", uncategorised$mo, ")"
|
||||
uncategorised$species, " (", uncategorised$mo, ")",
|
||||
collapse = "\n"
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
@ -41,7 +41,7 @@ expect_equal(
|
||||
)
|
||||
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_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_error(suppressWarnings(eucast_rules(example_isolates, col_mo = "Non-existing")))
|
||||
|
||||
@ -59,7 +59,7 @@ expect_inherits(mo_synonyms(c("Candida albicans", "Escherichia coli")), "list")
|
||||
expect_equal(names(mo_info("Escherichia coli")), c(
|
||||
"kingdom", "phylum", "class", "order",
|
||||
"family", "genus", "species", "subspecies",
|
||||
"synonyms", "gramstain", "url", "ref",
|
||||
"status", "synonyms", "gramstain", "url", "ref",
|
||||
"snomed"
|
||||
))
|
||||
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
|
||||
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
|
||||
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)
|
||||
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"))
|
||||
dutch <- mo_name(microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase")], language = "nl") # should be transformable to English again
|
||||
expect_identical(mo_name(dutch, language = NULL),
|
||||
microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase")]) # gigantic test - will run ALL names
|
||||
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, keep_synonyms = TRUE),
|
||||
microorganisms$fullname[which(microorganisms$fullname %unlike% "unknown|coagulase|Fungi")]) # gigantic test - will run ALL names
|
||||
|
||||
# manual property function
|
||||
expect_error(mo_property("Escherichia coli", property = c("genus", "fullname")))
|
||||
|
||||
@ -76,4 +76,3 @@ if (identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
|
||||
print(summary(out))
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user