diff --git a/DESCRIPTION b/DESCRIPTION
index 7dd2cacb..dfe1bfa0 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: AMR
-Version: 1.3.0.9017
-Date: 2020-09-12
+Version: 1.3.0.9018
+Date: 2020-09-14
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),
diff --git a/NEWS.md b/NEWS.md
index 6c57494a..9f837633 100755
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,5 @@
-# AMR 1.3.0.9017
-## Last updated: 12 September 2020
+# AMR 1.3.0.9018
+## Last updated: 14 September 2020
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscipt to. We are those reviewers very grateful for going through our code so thoroughly!
@@ -39,10 +39,10 @@ Note: some changes in this version were suggested by anonymous reviewers from th
#> [1] 24 24
```
* Improvements for `as.mo()`:
- * Any user input value that could mean more than one taxonomic entry is now considered 'uncertain'. Instead of a warning, a message will be thrown and the accompanying `mo_uncertainties()` has been changed completely; it now prints all possible candidates with their score.
+ * Any user input value that could mean more than one taxonomic entry is now considered 'uncertain'. Instead of a warning, a message will be thrown and the accompanying `mo_uncertainties()` has been changed completely; it now prints all possible candidates with their matching score.
* Big speed improvement for already valid microorganism ID. This also means an significant speed improvement for using `mo_*` functions like `mo_name()` on microoganism IDs.
* Added parameter `ignore_pattern` to `as.mo()` which can also be given to `mo_*` functions like `mo_name()`, to exclude known non-relevant input from analysing. This can also be set with the option `AMR_ignore_pattern`.
-* `get_locale()` now uses `Sys.getlocale()` instead of `Sys.getlocale("LC_COLLATE")`
+* `get_locale()` now uses at default `Sys.getenv("LANG")` or, if `LANG` is not set, `Sys.getlocale()`. This can be overwritten by setting the option `AMR_locale`.
* Speed improvement for `eucast_rules()`
* Overall speed improvement by tweaking joining functions
* Function `mo_shortname()` now returns the genus for input where the species is unknown
diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R
index 27124309..8a8d0702 100755
--- a/R/aa_helper_functions.R
+++ b/R/aa_helper_functions.R
@@ -644,7 +644,7 @@ file.mtime <- function(...) {
}
str2lang <- function(s) {
stopifnot(length(s) == 1L)
- ex <- parse(text = s, keep.source=FALSE)
+ ex <- parse(text = s, keep.source = FALSE)
stopifnot(length(ex) == 1L)
ex[[1L]]
}
diff --git a/R/mo.R b/R/mo.R
index 75e2dceb..973d6420 100755
--- a/R/mo.R
+++ b/R/mo.R
@@ -33,6 +33,7 @@
#' @param allow_uncertain a number between `0` (or `"none"`) and `3` (or `"all"`), or `TRUE` (= `2`) or `FALSE` (= `0`) to indicate whether the input should be checked for less probable results, please see *Details*
#' @param reference_df a [`data.frame`] to be used for extra reference when translating `x` to a valid [`mo`]. See [set_mo_source()] and [get_mo_source()] to automate the usage of your own codes (e.g. used in your analysis or organisation).
#' @param ignore_pattern a regular expression (case-insensitive) of which all matches in `x` must return `NA`. This can be convenient to exclude known non-relevant input and can also be set with the option `AMR_ignore_pattern`, e.g. `options(AMR_ignore_pattern = "(not reported|contaminated flora)")`.
+#' @param language language to translate text like "no growth", which defaults to the system language (see [get_locale()])
#' @param ... other parameters passed on to functions
#' @rdname as.mo
#' @aliases mo
@@ -86,7 +87,7 @@
#' - `"Fluoroquinolone-resistant Neisseria gonorrhoeae"`. The first word will be stripped, after which the function will try to find a match. A warning will be thrown that the result *Neisseria gonorrhoeae* (``r as.mo("Neisseria gonorrhoeae")``) needs review.
#'
#' There are three helper functions that can be run after using the [as.mo()] function:
-#' - Use [mo_uncertainties()] to get a [`data.frame`] that prints in a pretty format with all taxonomic names that were guessed. The output contains a score that is based on the human pathogenic prevalence and the [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) between the full taxonomic name and the user input.
+#' - Use [mo_uncertainties()] to get a [`data.frame`] that prints in a pretty format with all taxonomic names that were guessed. The output contains a score that is based on the human pathogenic prevalence and the [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) between the user input and the full taxonomic name.
#' - Use [mo_failures()] to get a [`character`] [`vector`] with all values that could not be coerced to a valid value.
#' - Use [mo_renamed()] to get a [`data.frame`] with all values that could be coerced based on old, previously accepted taxonomic names.
#'
@@ -175,6 +176,7 @@ as.mo <- function(x,
allow_uncertain = TRUE,
reference_df = get_mo_source(),
ignore_pattern = getOption("AMR_ignore_pattern"),
+ language = get_locale(),
...) {
check_dataset_integrity()
@@ -186,7 +188,7 @@ as.mo <- function(x,
# is.mo() won't work - codes might change between package versions
return(to_class_mo(x))
}
-
+
if (tryCatch(all(tolower(x) %in% MO_lookup$fullname_lower, na.rm = TRUE)
& isFALSE(Becker)
& isFALSE(Lancefield), error = function(e) FALSE)) {
@@ -203,10 +205,9 @@ as.mo <- function(x,
# WHONET: xxx = no growth
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
- # Laboratory systems: remove entries like "no growth", etc.
- x[trimws2(x) %like% "(no .*growth|keine? .*wachtstum|geen .*groei|no .*crecimientonon|sem .*crescimento|pas .*croissance)"] <- NA_character_
- x[trimws2(x) %like% "^(no|not|kein|geen|niet|non|sem) [a-z]+"] <- "UNKNOWN"
-
+ # Laboratory systems: remove (translated) entries like "no growth", etc.
+ x[trimws2(x) %like% translate_AMR("no .*growth", language = language)] <- NA_character_
+ x[trimws2(x) %like% paste0("^(", translate_AMR("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
if (mo_source_isvalid(reference_df)
@@ -244,8 +245,10 @@ as.mo <- function(x,
# will be checked for mo class in validation and uses exec_as.mo internally if necessary
y <- mo_validate(x = x, property = "mo",
Becker = Becker, Lancefield = Lancefield,
- allow_uncertain = uncertainty_level, reference_df = reference_df,
+ allow_uncertain = uncertainty_level,
+ reference_df = reference_df,
ignore_pattern = ignore_pattern,
+ language = language,
...)
}
@@ -268,6 +271,9 @@ is.mo <- function(x) {
# param dyslexia_mode logical - also check for characters that resemble others
# param debug logical - show different lookup texts while searching
# param reference_data_to_use data.frame - the data set to check for
+# param actual_uncertainty - (only for initial_search = FALSE) the actual uncertainty level used in the function for score calculation (sometimes passed as 2 or 3 by uncertain_fn())
+# param actual_input - (only for initial_search = FALSE) the actual, original input
+# param language - used for translating "no growth", etc.
exec_as.mo <- function(x,
Becker = FALSE,
Lancefield = FALSE,
@@ -278,33 +284,62 @@ exec_as.mo <- function(x,
dyslexia_mode = FALSE,
debug = FALSE,
ignore_pattern = getOption("AMR_ignore_pattern"),
- reference_data_to_use = MO_lookup) {
-
+ reference_data_to_use = MO_lookup,
+ actual_uncertainty = 1,
+ actual_input = NULL,
+ language = get_locale()) {
check_dataset_integrity()
- lookup <- function(needle, column = property, haystack = reference_data_to_use, n = 1, debug_mode = debug, input = "") {
+ lookup <- function(needle,
+ column = property,
+ haystack = reference_data_to_use,
+ n = 1,
+ debug_mode = debug,
+ initial = initial_search,
+ uncertainty = actual_uncertainty,
+ input_actual = actual_input) {
+
+ if (!is.null(input_actual)) {
+ input <- input_actual
+ } else {
+ input <- tryCatch(x_backup[i], error = function(e) "")
+ }
+
# `column` can be NULL for all columns, or a selection
# returns a character (vector) - if `column` > length 1 then with columns as names
if (isTRUE(debug_mode)) {
- cat(font_silver("looking up: ", substitute(needle), "\n", collapse = ""))
+ cat(font_silver("looking up: ", substitute(needle), collapse = ""))
}
if (length(column) == 1) {
res_df <- haystack[which(eval(substitute(needle), envir = haystack, enclos = parent.frame())), , drop = FALSE]
+ if (NROW(res_df) > 1) {
+ # sort the findings on matching score
+ res_df <- res_df[order(mo_matching_score(x_backup[i], res_df[, "fullname", drop = TRUE]), decreasing = TRUE), , drop = FALSE]
+ }
res <- as.character(res_df[, column, drop = TRUE])
if (length(res) == 0) {
+ if (isTRUE(debug_mode)) {
+ cat(font_red(" (no match)\n"))
+ }
NA_character_
} else {
- if (length(res) > n) {
+ if (isTRUE(debug_mode)) {
+ cat(font_green(paste0(" **MATCH** (", NROW(res_df), " results)\n")))
+ }
+ if (length(res) > n | uncertainty > 1) {
# save the other possible results as well
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = 1,
- input = x_backup[i],
+ format_uncertainty_as_df(uncertainty_level = uncertainty,
+ input = input,
result_mo = res_df[1, "mo", drop = TRUE],
candidates = as.character(res_df[, "fullname", drop = TRUE])))
}
res[seq_len(min(n, length(res)))]
}
} else {
+ if (isTRUE(debug_mode)) {
+ cat("\n")
+ }
if (is.null(column)) {
column <- names(haystack)
}
@@ -318,7 +353,7 @@ exec_as.mo <- function(x,
res
}
}
-
+
# start off with replaced language-specific non-ASCII characters with ASCII characters
x <- parse_and_convert(x)
# replace mo codes used in older package versions
@@ -328,9 +363,9 @@ exec_as.mo <- function(x,
# WHONET: xxx = no growth
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
- # Laboratory systems: remove entries like "no growth" etc
- x[trimws2(x) %like% "(no .*growth|keine? .*wachtstum|geen .*groei|no .*crecimientonon|sem .*crescimento|pas .*croissance)"] <- NA_character_
- x[trimws2(x) %like% "^(no|not|kein|geen|niet|non|sem) [a-z]+"] <- "UNKNOWN"
+ # Laboratory systems: remove (translated) entries like "no growth", etc.
+ x[trimws2(x) %like% translate_AMR("no .*growth", language = language)] <- NA_character_
+ x[trimws2(x) %like% paste0("^(", translate_AMR("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
if (initial_search == TRUE) {
options(mo_failures = NULL)
@@ -402,7 +437,7 @@ exec_as.mo <- function(x,
# we need special treatment for very prevalent full names, they are likely!
# e.g. as.mo("Staphylococcus aureus")
x <- MO_lookup[match(tolower(x), MO_lookup$fullname_lower), property, drop = TRUE]
-
+
} else if (all(x %in% reference_data_to_use$fullname)) {
# we need special treatment for very prevalent full names, they are likely!
# e.g. as.mo("Staphylococcus aureus")
@@ -981,7 +1016,7 @@ exec_as.mo <- function(x,
# (1) look again for old taxonomic names, now for G. species ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (1) look again for old taxonomic names, now for G. species\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (1) look again for old taxonomic names, now for G. species\n"))
}
if (isTRUE(debug)) {
message("Running '", d.x_withspaces_start_end, "' and '", e.x_withspaces_start_only, "'")
@@ -1015,24 +1050,22 @@ exec_as.mo <- function(x,
# (2) Try with misspelled input ----
# just rerun with dyslexia_mode = TRUE will used the extensive regex part above
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (2) Try with misspelled input\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (2) Try with misspelled input\n"))
}
if (isTRUE(debug)) {
message("Running '", a.x_backup, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 1, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 1, actual_input = a.x_backup)))
}
if (!empty_result(found)) {
found_result <- found
- found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
- input = a.x_backup,
- result_mo = found_result))
+ attr(found, which = "uncertainties", exact = TRUE))
+ found <- lookup(mo == found)
return(found)
}
}
@@ -1043,7 +1076,7 @@ exec_as.mo <- function(x,
# (3) look for genus only, part of name ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (3) look for genus only, part of name\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (3) look for genus only, part of name\n"))
}
if (nchar(g.x_backup_without_spp) > 4 & !b.x_trimmed %like_case% " ") {
if (!grepl("^[A-Z][a-z]+", b.x_trimmed, ignore.case = FALSE)) {
@@ -1067,7 +1100,7 @@ exec_as.mo <- function(x,
# (4) strip values between brackets ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (4) strip values between brackets\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (4) strip values between brackets\n"))
}
a.x_backup_stripped <- gsub("( *[(].*[)] *)", " ", a.x_backup)
a.x_backup_stripped <- trimws(gsub(" +", " ", a.x_backup_stripped))
@@ -1075,48 +1108,45 @@ exec_as.mo <- function(x,
message("Running '", a.x_backup_stripped, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_stripped, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_stripped, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_stripped, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_stripped, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
}
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found
- found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
- input = a.x_backup,
- result_mo = found_result))
+ attr(found, which = "uncertainties", exact = TRUE))
+ found <- lookup(mo == found)
return(found)
}
# (5) inverse input ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (5) inverse input\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (5) inverse input\n"))
}
a.x_backup_inversed <- paste(rev(unlist(strsplit(a.x_backup, split = " "))), collapse = " ")
if (isTRUE(debug)) {
message("Running '", a.x_backup_inversed, "'")
}
+
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_inversed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_inversed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_inversed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(a.x_backup_inversed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
}
if (!empty_result(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- found
- found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
- input = a.x_backup,
- result_mo = found_result))
+ attr(found, which = "uncertainties", exact = TRUE))
+ found <- lookup(mo == found)
return(found)
}
# (6) try to strip off half an element from end and check the remains ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (6) try to strip off half an element from end and check the remains\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (6) try to strip off half an element from end and check the remains\n"))
}
x_strip <- a.x_backup %>% strsplit("[ .]") %>% unlist()
if (length(x_strip) > 1) {
@@ -1130,18 +1160,16 @@ exec_as.mo <- function(x,
message("Running '", x_strip_collapsed, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
}
if (!empty_result(found)) {
found_result <- found
- found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
- input = a.x_backup,
- result_mo = found_result))
+ attr(found, which = "uncertainties", exact = TRUE))
+ found <- lookup(mo == found)
return(found)
}
}
@@ -1149,7 +1177,7 @@ exec_as.mo <- function(x,
}
# (7) try to strip off one element from end and check the remains ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n"))
}
if (length(x_strip) > 1) {
for (i in seq_len(length(x_strip) - 1)) {
@@ -1159,18 +1187,17 @@ exec_as.mo <- function(x,
message("Running '", x_strip_collapsed, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
}
+
if (!empty_result(found)) {
found_result <- found
- found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties,
- format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
- input = a.x_backup,
- result_mo = found_result))
+ attr(found, which = "uncertainties", exact = TRUE))
+ found <- lookup(mo == found)
return(found)
}
}
@@ -1178,7 +1205,7 @@ exec_as.mo <- function(x,
}
# (8) check for unknown yeasts/fungi ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (8) check for unknown yeasts/fungi\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (8) check for unknown yeasts/fungi\n"))
}
if (b.x_trimmed %like_case% "yeast") {
found <- "F_YEAST"
@@ -1202,7 +1229,7 @@ exec_as.mo <- function(x,
}
# (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome)\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome)\n"))
}
x_strip <- a.x_backup %>% strsplit("[ .]") %>% unlist()
if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) {
@@ -1212,10 +1239,10 @@ exec_as.mo <- function(x,
message("Running '", x_strip_collapsed, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 2, actual_input = a.x_backup)))
}
if (!empty_result(found)) {
found_result <- found
@@ -1239,7 +1266,7 @@ exec_as.mo <- function(x,
# (10) try to strip off one element from start and check the remains (any text size) ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (10) try to strip off one element from start and check the remains (any text size)\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (10) try to strip off one element from start and check the remains (any text size)\n"))
}
x_strip <- a.x_backup %>% strsplit("[ .]") %>% unlist()
if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) {
@@ -1249,10 +1276,10 @@ exec_as.mo <- function(x,
message("Running '", x_strip_collapsed, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 3, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 3, actual_input = a.x_backup)))
}
if (!empty_result(found)) {
found_result <- found
@@ -1268,7 +1295,7 @@ exec_as.mo <- function(x,
# (11) try to strip off one element from end and check the remains (any text size) ----
# (this is in fact 7 but without nchar limit of >=6)
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n"))
}
if (length(x_strip) > 1) {
for (i in seq_len(length(x_strip) - 1)) {
@@ -1277,10 +1304,10 @@ exec_as.mo <- function(x,
message("Running '", x_strip_collapsed, "'")
}
# first try without dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = FALSE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 3, actual_input = a.x_backup)))
if (empty_result(found)) {
# then with dyslexia mode
- found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use)))
+ found <- suppressMessages(suppressWarnings(exec_as.mo(x_strip_collapsed, initial_search = FALSE, dyslexia_mode = TRUE, allow_uncertain = FALSE, debug = debug, reference_data_to_use = uncertain.reference_data_to_use, actual_uncertainty = 3, actual_input = a.x_backup)))
}
if (!empty_result(found)) {
found_result <- found
@@ -1296,7 +1323,7 @@ exec_as.mo <- function(x,
# (12) part of a name (very unlikely match) ----
if (isTRUE(debug)) {
- cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (12) part of a name (very unlikely match)\n")
+ cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (12) part of a name (very unlikely match)\n"))
}
if (isTRUE(debug)) {
message("Running '", f.x_withspaces_end_only, "'")
@@ -1324,20 +1351,20 @@ exec_as.mo <- function(x,
e.x_withspaces_start_only = e.x_withspaces_start_only,
f.x_withspaces_end_only = f.x_withspaces_end_only,
g.x_backup_without_spp = g.x_backup_without_spp,
- uncertain.reference_data_to_use = MO_lookup[which(MO_lookup$prevalence %in% c(1, 2)), ])
- if (!empty_result(x[i])) {
- return(x[i])
- }
- x[i] <- uncertain_fn(a.x_backup = a.x_backup,
- b.x_trimmed = b.x_trimmed,
- d.x_withspaces_start_end = d.x_withspaces_start_end,
- e.x_withspaces_start_only = e.x_withspaces_start_only,
- f.x_withspaces_end_only = f.x_withspaces_end_only,
- g.x_backup_without_spp = g.x_backup_without_spp,
- uncertain.reference_data_to_use = MO_lookup[which(MO_lookup$prevalence == 3), ])
+ uncertain.reference_data_to_use = MO_lookup) # MO_lookup[which(MO_lookup$prevalence %in% c(1, 2)), ])
if (!empty_result(x[i])) {
return(x[i])
}
+ # x[i] <- uncertain_fn(a.x_backup = a.x_backup,
+ # b.x_trimmed = b.x_trimmed,
+ # d.x_withspaces_start_end = d.x_withspaces_start_end,
+ # e.x_withspaces_start_only = e.x_withspaces_start_only,
+ # f.x_withspaces_end_only = f.x_withspaces_end_only,
+ # g.x_backup_without_spp = g.x_backup_without_spp,
+ # uncertain.reference_data_to_use = MO_lookup[which(MO_lookup$prevalence == 3), ])
+ # if (!empty_result(x[i])) {
+ # return(x[i])
+ # }
# didn't found any
return(NA_character_)
@@ -1389,20 +1416,25 @@ exec_as.mo <- function(x,
if (n_distinct(failures) <= 10) {
msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ", "))
}
- msg <- paste0(msg, ".\nUse mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).")
+ msg <- paste0(msg,
+ ".\nUse mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).\n",
+ "You can also use your own reference data, e.g.:\n",
+ ' as.mo("mycode", reference_df = data.frame(own = "mycode", mo = "B_ESCHR_COLI"))\n',
+ ' mo_name("mycode", reference_df = data.frame(own = "mycode", mo = "B_ESCHR_COLI"))\n')
warning(font_red(paste0("\n", msg)),
call. = FALSE,
immediate. = TRUE) # thus will always be shown, even if >= warnings
}
# handling uncertainties ----
if (NROW(uncertainties) > 0 & initial_search == TRUE) {
- options(mo_uncertainties = as.list(distinct(uncertainties, input, .keep_all = TRUE)))
+ uncertainties <- as.list(distinct(uncertainties, input, .keep_all = TRUE))
+ options(mo_uncertainties = uncertainties)
plural <- c("", "it", "was")
- if (NROW(uncertainties) > 1) {
+ if (length(uncertainties$input) > 1) {
plural <- c("s", "them", "were")
}
- msg <- paste0("Result", plural[1], " of ", nr2char(NROW(uncertainties)), " value", plural[1],
+ msg <- paste0("Result", plural[1], " of ", nr2char(length(uncertainties$input)), " value", plural[1],
" ", plural[3], " guessed with uncertainty. Use mo_uncertainties() to review ", plural[2], ".")
message(font_blue(msg))
}
@@ -1501,6 +1533,11 @@ exec_as.mo <- function(x,
print(mo_renamed())
}
+ if (NROW(uncertainties) > 0 & initial_search == FALSE) {
+ # this will save the uncertain items as attribute, so they can be bound to `uncertainties` in the uncertain_fn() function
+ x <- structure(x, uncertainties = uncertainties)
+ }
+
if (old_mo_warning == TRUE & property != "mo") {
warning("The input contained old microorganism IDs from previous versions of this package.\nPlease use `as.mo()` on these old IDs to transform them to the new format.\nSUPPORT FOR THIS WILL BE DROPPED IN A FUTURE VERSION.", call. = FALSE)
}
@@ -1531,7 +1568,6 @@ format_uncertainty_as_df <- function(uncertainty_level,
input,
result_mo,
candidates = NULL) {
-
if (!is.null(getOption("mo_renamed_last_run", default = NULL))) {
fullname <- getOption("mo_renamed_last_run")
options(mo_renamed_last_run = NULL)
@@ -1545,8 +1581,8 @@ format_uncertainty_as_df <- function(uncertainty_level,
fullname = fullname,
renamed_to = renamed_to,
mo = result_mo,
- # save max 25 entries
- candidates = if (length(candidates) > 1) paste(candidates[c(2:min(25, length(candidates)))], collapse = ", ") else "",
+ # save max 26 entries: the one to be chosen and 25 more
+ candidates = if (length(candidates) > 1) paste(candidates[c(2:min(26, length(candidates)))], collapse = ", ") else "",
stringsAsFactors = FALSE)
}
@@ -1712,43 +1748,32 @@ print.mo_uncertainties <- function(x, ...) {
if (NROW(x) == 0) {
return(NULL)
}
- cat(paste0(font_bold(nr2char(nrow(x)), paste0("unique result", ifelse(nrow(x) > 1, "s", ""), " guessed with uncertainty:")),
- "\n(1 = ", font_green("renamed/misspelled"),
- ", 2 = ", font_yellow("uncertain"),
- ", 3 = ", font_red("very uncertain"), ")\n"))
+ cat(font_blue("Scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name.\n"))
msg <- ""
for (i in seq_len(nrow(x))) {
- if (x[i, "uncertainty"] == 1) {
- colour1 <- font_green
- colour2 <- function(...) font_green_bg(font_white(...))
- } else if (x[i, "uncertainty"] == 2) {
- colour1 <- font_yellow
- colour2 <- function(...) font_yellow_bg(font_black(...))
- } else {
- colour1 <- font_red
- colour2 <- function(...) font_red_bg(font_white(...))
- }
- if (x[i, "candidates"] != "") {
- candidates <- unlist(strsplit(x[i, "candidates"], ", ", fixed = TRUE))
- scores <- finding_score(x[i, "input"], candidates)
+ if (x[i, ]$candidates != "") {
+ candidates <- unlist(strsplit(x[i, ]$candidates, ", ", fixed = TRUE))
+ scores <- mo_matching_score(x[i, ]$input, candidates) * (1 / x[i, ]$uncertainty)
# sort on descending scores
candidates <- candidates[order(1 - scores)]
+ n_candidates <- length(candidates)
candidates <- paste0(font_italic(candidates, collapse = NULL),
" (", trimws(percentage(scores[order(1 - scores)], digits = 1)), ")")
candidates <- paste(candidates, collapse = ", ")
# align with input after arrow
- candidates <- paste0("\n", strrep(" ", nchar(x[i, "input"]) + 12), "Other: ", candidates)
+ candidates <- paste0("\n", strrep(" ", nchar(x[i, ]$input) + 6),
+ "Other", ifelse(n_candidates == 25, " (max 25)", ""), ": ", candidates)
} else {
candidates <- ""
}
msg <- paste(msg,
- paste0(colour2(paste0(" [", x[i, "uncertainty"], "] ")), ' "', x[i, "input"], '" -> ',
- colour1(paste0(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: ", trimws(percentage(finding_score(x[i, "input"], x[i, "fullname"]), digits = 1)),
- ")")),
+ paste0('"', x[i, ]$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: ", trimws(percentage(mo_matching_score(x[i, ]$input, x[i, ]$fullname) * (1 / x[i, ]$uncertainty), digits = 1)),
+ ")"),
candidates),
sep = "\n")
}
@@ -1834,24 +1859,24 @@ load_mo_failures_uncertainties_renamed <- function(metadata) {
options("mo_renamed" = metadata$renamed)
}
-finding_score <- function(input, output) {
- # output is always a valid fullname
+mo_matching_score <- function(input, fullname) {
+ # fullname is always a taxonomically valid full name
levenshtein <- double(length = length(input))
- if (length(output) == 1) {
- output <- rep(output, length(input))
+ if (length(fullname) == 1) {
+ fullname <- rep(fullname, length(input))
}
if (length(input) == 1) {
- input <- rep(input, length(output))
+ input <- rep(input, length(fullname))
}
for (i in seq_len(length(input))) {
- # determine Levenshtein distance, but maximise to nchar of output
- levenshtein[i] <- min(as.double(utils::adist(input[i], output[i], ignore.case = TRUE)),
- nchar(output[i]))
+ # determine Levenshtein distance, but maximise to nchar of fullname
+ levenshtein[i] <- min(as.double(utils::adist(input[i], fullname[i], ignore.case = FALSE)),
+ nchar(fullname[i]))
}
# self-made score between 0 and 1 (for % certainty, so 0 means huge distance, 1 means no distance)
- dist <- (nchar(output) - 0.5 * levenshtein) / nchar(output)
- index_in_MO_lookup <- tryCatch((nrow(MO_lookup) - match(output, MO_lookup$fullname)) / nrow(MO_lookup),
- error = function(e) rep(1, length(output)))
+ dist <- (nchar(fullname) - 0.5 * levenshtein) / nchar(fullname)
+ index_in_MO_lookup <- tryCatch((nrow(MO_lookup) - match(fullname, MO_lookup$fullname)) / nrow(MO_lookup),
+ error = function(e) rep(1, length(fullname)))
dist * index_in_MO_lookup
}
diff --git a/R/mo_property.R b/R/mo_property.R
index c40e99df..2e6e2e43 100755
--- a/R/mo_property.R
+++ b/R/mo_property.R
@@ -141,7 +141,7 @@
#' mo_info("E. coli")
#' }
mo_name <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "fullname", ...), language = language, only_unknown = FALSE)
+ translate_AMR(mo_validate(x = x, property = "fullname", language = language, ...), language = language, only_unknown = FALSE)
}
#' @rdname mo_property
@@ -151,7 +151,7 @@ mo_fullname <- mo_name
#' @rdname mo_property
#' @export
mo_shortname <- function(x, language = get_locale(), ...) {
- x.mo <- as.mo(x, ...)
+ x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
@@ -181,49 +181,49 @@ mo_shortname <- function(x, language = get_locale(), ...) {
#' @rdname mo_property
#' @export
mo_subspecies <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "subspecies", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_species <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "species", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_genus <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "genus", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_family <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "family", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_order <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "order", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_class <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "class", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_phylum <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "phylum", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
#' @export
mo_kingdom <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "kingdom", ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
}
#' @rdname mo_property
@@ -233,13 +233,13 @@ mo_domain <- mo_kingdom
#' @rdname mo_property
#' @export
mo_type <- function(x, language = get_locale(), ...) {
- translate_AMR(mo_validate(x = x, property = "kingdom", ...), language = language, only_unknown = FALSE)
+ translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = FALSE)
}
#' @rdname mo_property
#' @export
mo_gramstain <- function(x, language = get_locale(), ...) {
- x.mo <- as.mo(x, ...)
+ x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x.phylum <- mo_phylum(x.mo)
@@ -269,20 +269,20 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
#' @rdname mo_property
#' @export
-mo_snomed <- function(x, ...) {
- mo_validate(x = x, property = "snomed", ...)
+mo_snomed <- function(x, language = get_locale(), ...) {
+ mo_validate(x = x, property = "snomed", language = language, ...)
}
#' @rdname mo_property
#' @export
-mo_ref <- function(x, ...) {
- mo_validate(x = x, property = "ref", ...)
+mo_ref <- function(x, language = get_locale(), ...) {
+ mo_validate(x = x, property = "ref", language = language, ...)
}
#' @rdname mo_property
#' @export
-mo_authors <- function(x, ...) {
- x <- mo_validate(x = x, property = "ref", ...)
+mo_authors <- function(x, language = get_locale(), ...) {
+ x <- mo_validate(x = x, property = "ref", language = language, ...)
# remove last 4 digits and presumably the comma and space that preceed them
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)])
suppressWarnings(x)
@@ -290,8 +290,8 @@ mo_authors <- function(x, ...) {
#' @rdname mo_property
#' @export
-mo_year <- function(x, ...) {
- x <- mo_validate(x = x, property = "ref", ...)
+mo_year <- function(x, language = get_locale(), ...) {
+ x <- mo_validate(x = x, property = "ref", language = language, ...)
# get last 4 digits
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)])
suppressWarnings(as.integer(x))
@@ -299,14 +299,14 @@ mo_year <- function(x, ...) {
#' @rdname mo_property
#' @export
-mo_rank <- function(x, ...) {
- mo_validate(x = x, property = "rank", ...)
+mo_rank <- function(x, language = get_locale(), ...) {
+ mo_validate(x = x, property = "rank", language = language, ...)
}
#' @rdname mo_property
#' @export
mo_taxonomy <- function(x, language = get_locale(), ...) {
- x <- as.mo(x, ...)
+ x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
result <- list(kingdom = mo_kingdom(x, language = language),
@@ -324,8 +324,8 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
#' @rdname mo_property
#' @export
-mo_synonyms <- function(x, ...) {
- x <- as.mo(x, ...)
+mo_synonyms <- function(x, language = get_locale(), ...) {
+ x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_name(x = x, language = NULL)
@@ -351,7 +351,7 @@ mo_synonyms <- function(x, ...) {
#' @rdname mo_property
#' @export
mo_info <- function(x, language = get_locale(), ...) {
- x <- as.mo(x, ...)
+ x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y)
@@ -373,8 +373,8 @@ mo_info <- function(x, language = get_locale(), ...) {
#' @rdname mo_property
#' @export
-mo_url <- function(x, open = FALSE, ...) {
- mo <- as.mo(x = x, ... = ...)
+mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
+ mo <- as.mo(x = x, language = language, ... = ...)
mo_names <- mo_name(mo)
metadata <- get_mo_failures_uncertainties_renamed()
@@ -407,10 +407,10 @@ mo_property <- function(x, property = "fullname", language = get_locale(), ...)
stop_ifnot(property %in% colnames(microorganisms),
"invalid property: '", property, "' - use a column name of the `microorganisms` data set")
- translate_AMR(mo_validate(x = x, property = property, ...), language = language, only_unknown = TRUE)
+ translate_AMR(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
}
-mo_validate <- function(x, property, ...) {
+mo_validate <- function(x, property, language, ...) {
check_dataset_integrity()
@@ -439,11 +439,11 @@ mo_validate <- function(x, property, ...) {
& !Lancefield %in% c(TRUE, "all")) {
# this will not reset mo_uncertainties and mo_failures
# because it's already a valid MO
- x <- exec_as.mo(x, property = property, initial_search = FALSE, ...)
+ x <- exec_as.mo(x, property = property, initial_search = FALSE, language = language, ...)
} else if (!all(x %in% MO_lookup[, property, drop = TRUE])
| Becker %in% c(TRUE, "all")
| Lancefield %in% c(TRUE, "all")) {
- x <- exec_as.mo(x, property = property, ...)
+ x <- exec_as.mo(x, property = property, language = language, ...)
}
if (property == "mo") {
diff --git a/R/sysdata.rda b/R/sysdata.rda
index 2d2f2c6d..b1429c5c 100644
Binary files a/R/sysdata.rda and b/R/sysdata.rda differ
diff --git a/R/translate.R b/R/translate.R
index daf9410f..40956ddd 100755
--- a/R/translate.R
+++ b/R/translate.R
@@ -23,13 +23,19 @@
#'
#' For language-dependent output of AMR functions, like [mo_name()], [mo_gramstain()], [mo_type()] and [ab_name()].
#' @inheritSection lifecycle Stable lifecycle
-#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: . This file will be read by all functions where a translated output can be desired, like all [mo_property()] functions ([mo_name()], [mo_gramstain()], [mo_type()], etc.).
+#' @details Strings will be translated to foreign languages if they are defined in a local translation file. Additions to this file can be suggested at our repository. The file can be found here: . This file will be read by all functions where a translated output can be desired, like all [mo_property()] functions ([mo_name()], [mo_gramstain()], [mo_type()], etc.) and [ab_property()] functions ([ab_name()], [ab_group()] etc.).
#'
#' Currently supported languages are: `r paste(sort(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"])), collapse = ", ")`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#'
#' Please suggest your own translations [by creating a new issue on our repository](https://github.com/msberends/AMR/issues/new?title=Translations).
#'
-#' The system language will be used at default (as returned by [Sys.getlocale()]), if that language is supported. The language to be used can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`.
+#' ## 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()]), 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`, e.g. by running `options(AMR_locale = "de")`
+#' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory
+#'
+#' So if the R option `AMR_locale` is set, the system variables `LANGUAGE` and `LANG` will be ignored.
#' @inheritSection AMR Read more on our website!
#' @rdname translate
#' @name translate
@@ -73,17 +79,24 @@ get_locale <- function() {
if (lang %in% LANGUAGES_SUPPORTED) {
return(lang)
} else {
- stop_("unsupported language: '", lang, "' - use one of: ",
+ stop_("unsupported language set as option 'AMR_locale': '", lang, "' - use one of: ",
paste0("'", LANGUAGES_SUPPORTED, "'", collapse = ", "))
}
+ } else {
+ # we now support the LANGUAGE system variable - return it if set
+ if (!identical("", Sys.getenv("LANGUAGE"))) {
+ return(coerce_language_setting(Sys.getenv("LANGUAGE")))
+ }
+ if (!identical("", Sys.getenv("LANG"))) {
+ return(coerce_language_setting(Sys.getenv("LANG")))
+ }
}
- lang <- Sys.getlocale()
-
- # Check the locale settings for a start with one of these languages:
-
+ coerce_language_setting(Sys.getlocale())
+}
+
+coerce_language_setting <- function(lang) {
# grepl() with ignore.case = FALSE is faster than %like%
-
if (grepl("^(English|en_|EN_)", lang, ignore.case = FALSE)) {
# as first option to optimise speed
"en"
diff --git a/data-raw/ab.md5 b/data-raw/ab.md5
new file mode 100644
index 00000000..6b825550
--- /dev/null
+++ b/data-raw/ab.md5
@@ -0,0 +1 @@
+37a7be09e34b5ec657a4bad94f45f355
diff --git a/data-raw/av.md5 b/data-raw/av.md5
new file mode 100644
index 00000000..ddb76c34
--- /dev/null
+++ b/data-raw/av.md5
@@ -0,0 +1 @@
+7b6649442069d3d121f61ca3ff01843a
diff --git a/data-raw/internals.R b/data-raw/internals.R
index 502a69e2..b044a9af 100644
--- a/data-raw/internals.R
+++ b/data-raw/internals.R
@@ -25,19 +25,19 @@
# See 'data-raw/eucast_rules.tsv' for the EUCAST reference file
eucast_rules_file <- utils::read.delim(file = "data-raw/eucast_rules.tsv",
- skip = 10,
- sep = "\t",
- stringsAsFactors = FALSE,
- header = TRUE,
- strip.white = TRUE,
- na = c(NA, "", NULL))
+ skip = 10,
+ sep = "\t",
+ stringsAsFactors = FALSE,
+ header = TRUE,
+ strip.white = TRUE,
+ na = c(NA, "", NULL))
# take the order of the reference.rule_group column in the original data file
eucast_rules_file$reference.rule_group <- factor(eucast_rules_file$reference.rule_group,
levels = unique(eucast_rules_file$reference.rule_group),
ordered = TRUE)
eucast_rules_file <- dplyr::arrange(eucast_rules_file,
- reference.rule_group,
- reference.rule)
+ reference.rule_group,
+ reference.rule)
eucast_rules_file$reference.rule_group <- as.character(eucast_rules_file$reference.rule_group)
# Translations ----
@@ -62,7 +62,8 @@ microorganisms.translation <- readRDS("data-raw/microorganisms.translation.rds")
usethis::use_data(eucast_rules_file, translations_file, microorganisms.translation,
internal = TRUE,
overwrite = TRUE,
- version = 2)
+ version = 2,
+ compress = "xz")
# Remove from global environment ----
rm(eucast_rules_file)
@@ -70,51 +71,83 @@ rm(translations_file)
rm(microorganisms.translation)
# Save to raw data to repository ----
+write_md5 <- function(object) {
+ writeLines(digest::digest(object, "md5"), file(paste0("data-raw/", deparse(substitute(object)), ".md5")))
+}
+changed_md5 <- function(object) {
+ tryCatch({
+ conn <- file(paste0("data-raw/", deparse(substitute(object)), ".md5"))
+ compared <- digest::digest(object, "md5") != readLines(con = conn)
+ close(conn)
+ compared
+ }, error = function(e) TRUE)
+}
usethis::ui_done(paste0("Saving raw data to {usethis::ui_value('/data-raw/')}"))
devtools::load_all(quiet = TRUE)
# give official names to ABs and MOs
rsi <- dplyr::mutate(rsi_translation, ab = ab_name(ab), mo = mo_name(mo))
-try(saveRDS(rsi, "data-raw/rsi_translation.rds", version = 2), silent = TRUE)
-try(write.table(rsi, "data-raw/rsi_translation.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(rsi, "data-raw/rsi_translation.sas"), silent = TRUE)
-try(haven::write_sav(rsi, "data-raw/rsi_translation.sav"), silent = TRUE)
-try(haven::write_dta(rsi, "data-raw/rsi_translation.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(rsi, "data-raw/rsi_translation.xlsx"), silent = TRUE)
+if (changed_md5(rsi)) {
+ write_md5(rsi)
+ try(saveRDS(rsi, "data-raw/rsi_translation.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(rsi, "data-raw/rsi_translation.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(rsi, "data-raw/rsi_translation.sas"), silent = TRUE)
+ try(haven::write_sav(rsi, "data-raw/rsi_translation.sav"), silent = TRUE)
+ try(haven::write_dta(rsi, "data-raw/rsi_translation.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(rsi, "data-raw/rsi_translation.xlsx"), silent = TRUE)
+}
mo <- dplyr::mutate_if(microorganisms, ~!is.numeric(.), as.character)
-try(saveRDS(mo, "data-raw/microorganisms.rds", version = 2), silent = TRUE)
-try(write.table(mo, "data-raw/microorganisms.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(mo, "data-raw/microorganisms.sas"), silent = TRUE)
-try(haven::write_sav(mo, "data-raw/microorganisms.sav"), silent = TRUE)
-try(haven::write_dta(mo, "data-raw/microorganisms.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(mo, "data-raw/microorganisms.xlsx"), silent = TRUE)
+if (changed_md5(mo)) {
+ write_md5(mo)
+ try(saveRDS(mo, "data-raw/microorganisms.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(mo, "data-raw/microorganisms.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(mo, "data-raw/microorganisms.sas"), silent = TRUE)
+ try(haven::write_sav(mo, "data-raw/microorganisms.sav"), silent = TRUE)
+ try(haven::write_dta(mo, "data-raw/microorganisms.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(mo, "data-raw/microorganisms.xlsx"), silent = TRUE)
+}
-try(saveRDS(microorganisms.old, "data-raw/microorganisms.old.rds", version = 2), silent = TRUE)
-try(write.table(microorganisms.old, "data-raw/microorganisms.old.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(microorganisms.old, "data-raw/microorganisms.old.sas"), silent = TRUE)
-try(haven::write_sav(microorganisms.old, "data-raw/microorganisms.old.sav"), silent = TRUE)
-try(haven::write_dta(microorganisms.old, "data-raw/microorganisms.old.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(microorganisms.old, "data-raw/microorganisms.old.xlsx"), silent = TRUE)
+if (changed_md5(microorganisms.old)) {
+ write_md5(microorganisms.old)
+ try(saveRDS(microorganisms.old, "data-raw/microorganisms.old.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(microorganisms.old, "data-raw/microorganisms.old.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(microorganisms.old, "data-raw/microorganisms.old.sas"), silent = TRUE)
+ try(haven::write_sav(microorganisms.old, "data-raw/microorganisms.old.sav"), silent = TRUE)
+ try(haven::write_dta(microorganisms.old, "data-raw/microorganisms.old.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(microorganisms.old, "data-raw/microorganisms.old.xlsx"), silent = TRUE)
+}
ab <- dplyr::mutate_if(antibiotics, ~!is.numeric(.), as.character)
-try(saveRDS(ab, "data-raw/antibiotics.rds", version = 2), silent = TRUE)
-try(write.table(ab, "data-raw/antibiotics.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(ab, "data-raw/antibiotics.sas"), silent = TRUE)
-try(haven::write_sav(ab, "data-raw/antibiotics.sav"), silent = TRUE)
-try(haven::write_dta(ab, "data-raw/antibiotics.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(ab, "data-raw/antibiotics.xlsx"), silent = TRUE)
+if (changed_md5(ab)) {
+ write_md5(ab)
+ try(saveRDS(ab, "data-raw/antibiotics.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(ab, "data-raw/antibiotics.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(ab, "data-raw/antibiotics.sas"), silent = TRUE)
+ try(haven::write_sav(ab, "data-raw/antibiotics.sav"), silent = TRUE)
+ try(haven::write_dta(ab, "data-raw/antibiotics.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(ab, "data-raw/antibiotics.xlsx"), silent = TRUE)
+}
av <- dplyr::mutate_if(antivirals, ~!is.numeric(.), as.character)
-try(saveRDS(av, "data-raw/antivirals.rds", version = 2), silent = TRUE)
-try(write.table(av, "data-raw/antivirals.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(av, "data-raw/antivirals.sas"), silent = TRUE)
-try(haven::write_sav(av, "data-raw/antivirals.sav"), silent = TRUE)
-try(haven::write_dta(av, "data-raw/antivirals.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(av, "data-raw/antivirals.xlsx"), silent = TRUE)
+if (changed_md5(av)) {
+ write_md5(av)
+ try(saveRDS(av, "data-raw/antivirals.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(av, "data-raw/antivirals.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(av, "data-raw/antivirals.sas"), silent = TRUE)
+ try(haven::write_sav(av, "data-raw/antivirals.sav"), silent = TRUE)
+ try(haven::write_dta(av, "data-raw/antivirals.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(av, "data-raw/antivirals.xlsx"), silent = TRUE)
+}
-try(saveRDS(intrinsic_resistant, "data-raw/intrinsic_resistant.rds", version = 2), silent = TRUE)
-try(write.table(intrinsic_resistant, "data-raw/intrinsic_resistant.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
-try(haven::write_sas(intrinsic_resistant, "data-raw/intrinsic_resistant.sas"), silent = TRUE)
-try(haven::write_sav(intrinsic_resistant, "data-raw/intrinsic_resistant.sav"), silent = TRUE)
-try(haven::write_dta(intrinsic_resistant, "data-raw/intrinsic_resistant.dta"), silent = TRUE)
-try(openxlsx::write.xlsx(intrinsic_resistant, "data-raw/intrinsic_resistant.xlsx"), silent = TRUE)
+if (changed_md5(intrinsic_resistant)) {
+ write_md5(intrinsic_resistant)
+ try(saveRDS(intrinsic_resistant, "data-raw/intrinsic_resistant.rds", version = 2, compress = "xz"), silent = TRUE)
+ try(write.table(intrinsic_resistant, "data-raw/intrinsic_resistant.txt", sep = "\t", na = "", row.names = FALSE), silent = TRUE)
+ try(haven::write_sas(intrinsic_resistant, "data-raw/intrinsic_resistant.sas"), silent = TRUE)
+ try(haven::write_sav(intrinsic_resistant, "data-raw/intrinsic_resistant.sav"), silent = TRUE)
+ try(haven::write_dta(intrinsic_resistant, "data-raw/intrinsic_resistant.dta"), silent = TRUE)
+ try(openxlsx::write.xlsx(intrinsic_resistant, "data-raw/intrinsic_resistant.xlsx"), silent = TRUE)
+}
+
+rm(write_md5)
+rm(changed_md5)
diff --git a/data-raw/intrinsic_resistant.md5 b/data-raw/intrinsic_resistant.md5
new file mode 100644
index 00000000..6808c0ba
--- /dev/null
+++ b/data-raw/intrinsic_resistant.md5
@@ -0,0 +1 @@
+6915f562bd64e546e1d57741a2a5ad27
diff --git a/data-raw/microorganisms.old.md5 b/data-raw/microorganisms.old.md5
new file mode 100644
index 00000000..43703dcb
--- /dev/null
+++ b/data-raw/microorganisms.old.md5
@@ -0,0 +1 @@
+617b59b8ac3bd1aad7847aafc328f0f3
diff --git a/data-raw/mo.md5 b/data-raw/mo.md5
new file mode 100644
index 00000000..b415f54f
--- /dev/null
+++ b/data-raw/mo.md5
@@ -0,0 +1 @@
+a5b85c5b3d37d6330865dfe09ef9b354
diff --git a/data-raw/rsi.md5 b/data-raw/rsi.md5
new file mode 100644
index 00000000..9d263be4
--- /dev/null
+++ b/data-raw/rsi.md5
@@ -0,0 +1 @@
+0ac715df4f94c8704ae1d9bf56913312
diff --git a/data-raw/translations.tsv b/data-raw/translations.tsv
index b533a956..192357cb 100644
--- a/data-raw/translations.tsv
+++ b/data-raw/translations.tsv
@@ -27,6 +27,7 @@ de vegetative vegetativ FALSE FALSE
de ([([ ]*?)group \\1Gruppe FALSE FALSE
de ([([ ]*?)Group \\1Gruppe FALSE FALSE
de no .*growth keine? .*wachstum FALSE TRUE
+de no|not keine? FALSE TRUE
nl Coagulase-negative Staphylococcus Coagulase-negatieve Staphylococcus FALSE FALSE
nl Coagulase-positive Staphylococcus Coagulase-positieve Staphylococcus FALSE FALSE
@@ -58,6 +59,8 @@ nl antibiotic antibioticum FALSE FALSE
nl Antibiotic Antibioticum FALSE FALSE
nl Drug Middel FALSE FALSE
nl drug middel FALSE FALSE
+nl no .*growth geen .*groei FALSE TRUE
+nl no|not geen|niet FALSE TRUE
es Coagulase-negative Staphylococcus Staphylococcus coagulasa negativo FALSE FALSE
es Coagulase-positive Staphylococcus Staphylococcus coagulasa positivo FALSE FALSE
@@ -86,6 +89,8 @@ es biotype biotipo FALSE FALSE
es vegetative vegetativo FALSE FALSE
es ([([ ]*?)group \\1grupo FALSE FALSE
es ([([ ]*?)Group \\1Grupo FALSE FALSE
+es no .*growth no .*crecimientonon FALSE TRUE
+es no|not no|sin FALSE TRUE
it Coagulase-negative Staphylococcus Staphylococcus negativo coagulasi FALSE FALSE
it Coagulase-positive Staphylococcus Staphylococcus positivo coagulasi FALSE FALSE
@@ -112,6 +117,8 @@ it biotype biotipo FALSE FALSE
it vegetative vegetativo FALSE FALSE
it ([([ ]*?)group \\1gruppo FALSE FALSE
it ([([ ]*?)Group \\1Gruppo FALSE FALSE
+it no .*growth sem .*crescimento FALSE TRUE
+it no|not sem FALSE TRUE
fr Coagulase-negative Staphylococcus Staphylococcus à coagulase négative FALSE FALSE
fr Coagulase-positive Staphylococcus Staphylococcus à coagulase positif FALSE FALSE
@@ -137,6 +144,8 @@ fr biogroup biogroupe FALSE FALSE
fr vegetative végétatif FALSE FALSE
fr ([([ ]*?)group \\1groupe FALSE FALSE
fr ([([ ]*?)Group \\1Groupe FALSE FALSE
+fr no .*growth pas .*croissance FALSE TRUE
+fr no|not non FALSE TRUE
pt Coagulase-negative Staphylococcus Staphylococcus coagulase negativo FALSE FALSE
pt Coagulase-positive Staphylococcus Staphylococcus coagulase positivo FALSE FALSE
@@ -163,6 +172,8 @@ pt biotype biótipo FALSE FALSE
pt vegetative vegetativo FALSE FALSE
pt ([([ ]*?)group \\1grupo FALSE FALSE
pt ([([ ]*?)Group \\1Grupo FALSE FALSE
+pt no .*growth sem .*crescimento FALSE TRUE
+pt no|not sem FALSE TRUE
de clavulanic acid Clavulansäure FALSE TRUE
diff --git a/docs/404.html b/docs/404.html
index 942ccef7..9859af5e 100644
--- a/docs/404.html
+++ b/docs/404.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html
index cde6600d..f60a221a 100644
--- a/docs/LICENSE-text.html
+++ b/docs/LICENSE-text.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
diff --git a/docs/articles/index.html b/docs/articles/index.html
index 445d9b12..56b82aad 100644
--- a/docs/articles/index.html
+++ b/docs/articles/index.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
diff --git a/docs/authors.html b/docs/authors.html
index 2708d2b1..72e7cc75 100644
--- a/docs/authors.html
+++ b/docs/authors.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
diff --git a/docs/index.html b/docs/index.html
index e31429fd..c5dac937 100644
--- a/docs/index.html
+++ b/docs/index.html
@@ -43,7 +43,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
diff --git a/docs/news/index.html b/docs/news/index.html
index 52768e23..a21f043f 100644
--- a/docs/news/index.html
+++ b/docs/news/index.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.3.0.9017
+ 1.3.0.9018
@@ -236,13 +236,13 @@
Source: NEWS.md
-
-