Browse Source

(v1.3.0.9018) language corrections

pull/67/head
parent
commit
7b6dd676f7
  1. 4
      DESCRIPTION
  2. 8
      NEWS.md
  3. 2
      R/aa_helper_functions.R
  4. 265
      R/mo.R
  5. 64
      R/mo_property.R
  6. BIN
      R/sysdata.rda
  7. 29
      R/translate.R
  8. 1
      data-raw/ab.md5
  9. 1
      data-raw/av.md5
  10. 123
      data-raw/internals.R
  11. 1
      data-raw/intrinsic_resistant.md5
  12. 1
      data-raw/microorganisms.old.md5
  13. 1
      data-raw/mo.md5
  14. 1
      data-raw/rsi.md5
  15. 11
      data-raw/translations.tsv
  16. 2
      docs/404.html
  17. 2
      docs/LICENSE-text.html
  18. 2
      docs/articles/index.html
  19. 2
      docs/authors.html
  20. 2
      docs/index.html
  21. 16
      docs/news/index.html
  22. 2
      docs/pkgdown.yml
  23. 9
      docs/reference/as.mo.html
  24. 2
      docs/reference/index.html
  25. 16
      docs/reference/mo_property.html
  26. 16
      docs/reference/translate.html
  27. 2
      docs/survey.html
  28. 5
      man/as.mo.Rd
  29. 14
      man/mo_property.Rd
  30. 12
      man/translate.Rd

4
DESCRIPTION

@ -1,6 +1,6 @@ @@ -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"),

8
NEWS.md

@ -1,5 +1,5 @@ @@ -1,5 +1,5 @@
# AMR 1.3.0.9017
## <small>Last updated: 12 September 2020</small>
# AMR 1.3.0.9018
## <small>Last updated: 14 September 2020</small>
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 @@ -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

2
R/aa_helper_functions.R

@ -644,7 +644,7 @@ file.mtime <- function(...) { @@ -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]]
}

265
R/mo.R

@ -33,6 +33,7 @@ @@ -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 @@ @@ -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, @@ -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, @@ -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, @@ -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, @@ -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) { @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, @@ -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, ...) { @@ -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) { @@ -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
}

64
R/mo_property.R

@ -141,7 +141,7 @@ @@ -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 @@ -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(), ...) { @@ -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 @@ -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(), ...) { @@ -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, ...) { @@ -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, ...) { @@ -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(), ...) { @@ -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, ...) { @@ -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(), ...) { @@ -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(), ...) @@ -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, ...) { @@ -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") {

BIN
R/sysdata.rda

Binary file not shown.

29
R/translate.R

@ -23,13 +23,19 @@ @@ -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: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. 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: <https://github.com/msberends/AMR/blob/master/data-raw/translations.tsv>. 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() { @@ -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"

1
data-raw/ab.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
37a7be09e34b5ec657a4bad94f45f355

1
data-raw/av.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
7b6649442069d3d121f61ca3ff01843a

123
data-raw/internals.R

@ -25,19 +25,19 @@ @@ -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") @@ -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) @@ -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)
}
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)
}
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)
rm(write_md5)
rm(changed_md5)

1
data-raw/intrinsic_resistant.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
6915f562bd64e546e1d57741a2a5ad27

1
data-raw/microorganisms.old.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
617b59b8ac3bd1aad7847aafc328f0f3

1
data-raw/mo.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
a5b85c5b3d37d6330865dfe09ef9b354

1
data-raw/rsi.md5

@ -0,0 +1 @@ @@ -0,0 +1 @@
0ac715df4f94c8704ae1d9bf56913312

11
data-raw/translations.tsv