mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 08:11:58 +02:00
language updates
This commit is contained in:
8
R/ab.R
8
R/ab.R
@ -282,9 +282,9 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
# INITIAL SEARCH - More uncertain results ----
|
||||
|
||||
|
||||
if (initial_search == TRUE && fast_mode == FALSE) {
|
||||
# only run on first try
|
||||
|
||||
@ -313,7 +313,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
|
||||
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
|
||||
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
|
||||
y[i])
|
||||
}
|
||||
}
|
||||
@ -463,7 +463,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
warning_("in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
|
||||
vector_and(x_unknown), ".")
|
||||
}
|
||||
|
||||
|
||||
x_result <- x_new[match(x_bak_clean, x)]
|
||||
if (length(x_result) == 0) {
|
||||
x_result <- NA_character_
|
||||
|
||||
@ -125,7 +125,7 @@ ab_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(tolower, allow_class = "logical", has_length = 1)
|
||||
|
||||
x <- translate_AMR(ab_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
|
||||
x <- translate_into_language(ab_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
|
||||
if (tolower == TRUE) {
|
||||
# use perl to only transform the first character
|
||||
# as we want "polymyxin B", not "polymyxin b"
|
||||
@ -166,7 +166,7 @@ ab_tradenames <- function(x, ...) {
|
||||
ab_group <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "group", ...), language = language, only_affect_ab_names = TRUE)
|
||||
translate_into_language(ab_validate(x = x, property = "group", ...), language = language, only_affect_ab_names = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
@ -204,7 +204,7 @@ ab_atc <- function(x, only_first = FALSE, ...) {
|
||||
ab_atc_group1 <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "atc_group1", ...), language = language, only_affect_ab_names = TRUE)
|
||||
translate_into_language(ab_validate(x = x, property = "atc_group1", ...), language = language, only_affect_ab_names = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
@ -212,7 +212,7 @@ ab_atc_group1 <- function(x, language = get_AMR_locale(), ...) {
|
||||
ab_atc_group2 <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = "atc_group2", ...), language = language, only_affect_ab_names = TRUE)
|
||||
translate_into_language(ab_validate(x = x, property = "atc_group2", ...), language = language, only_affect_ab_names = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
@ -331,7 +331,7 @@ ab_property <- function(x, property = "name", language = get_AMR_locale(), ...)
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1)
|
||||
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
|
||||
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
|
||||
translate_into_language(ab_validate(x = x, property = property, ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
@ -430,7 +430,7 @@ ab_validate <- function(x, property, ...) {
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% antibiotics[1, property],
|
||||
error = function(e) stop(e$message, call. = FALSE))
|
||||
|
||||
|
||||
if (!all(x %in% AB_lookup[, property])) {
|
||||
x <- as.ab(x, ...)
|
||||
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
|
||||
|
||||
@ -285,7 +285,7 @@ format.bug_drug_combinations <- function(x,
|
||||
y <- y %pm>%
|
||||
pm_select(-ab_group) %pm>%
|
||||
pm_rename("Drug" = ab_txt)
|
||||
colnames(y)[1] <- translate_AMR(colnames(y)[1], language, only_unknown = FALSE)
|
||||
colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE)
|
||||
} else {
|
||||
y <- y %pm>%
|
||||
pm_rename("Group" = ab_group,
|
||||
@ -293,7 +293,7 @@ format.bug_drug_combinations <- function(x,
|
||||
}
|
||||
|
||||
if (!is.null(language)) {
|
||||
colnames(y) <- translate_AMR(colnames(y), language, only_unknown = FALSE)
|
||||
colnames(y) <- translate_into_language(colnames(y), language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
if (remove_intrinsic_resistant == TRUE) {
|
||||
|
||||
80
R/mo.R
80
R/mo.R
@ -174,7 +174,7 @@ as.mo <- function(x,
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo)
|
||||
& isFALSE(Becker)
|
||||
& isFALSE(Lancefield), error = function(e) FALSE)) {
|
||||
@ -182,19 +182,19 @@ as.mo <- function(x,
|
||||
# is.mo() won't work - MO codes might change between package versions
|
||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||
}
|
||||
|
||||
|
||||
# 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
|
||||
x <- replace_old_mo_codes(x, property = "mo")
|
||||
# ignore cases that match the ignore pattern
|
||||
x <- replace_ignore_pattern(x, ignore_pattern)
|
||||
|
||||
|
||||
# WHONET: xxx = no growth
|
||||
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
|
||||
# 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"
|
||||
x[trimws2(x) %like% translate_into_language("no .*growth", language = language)] <- NA_character_
|
||||
x[trimws2(x) %like% paste0("^(", translate_into_language("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
|
||||
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
|
||||
|
||||
if (tryCatch(all(x == "" | gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE) %in% MO_lookup$fullname_lower, na.rm = TRUE)
|
||||
@ -204,25 +204,25 @@ as.mo <- function(x,
|
||||
return(set_clean_class(MO_lookup[match(gsub(".*(unknown ).*", "unknown name", tolower(x), perl = TRUE), MO_lookup$fullname_lower), "mo", drop = TRUE],
|
||||
new_class = c("mo", "character")))
|
||||
}
|
||||
|
||||
|
||||
if (!is.null(reference_df)
|
||||
&& check_validity_mo_source(reference_df)
|
||||
&& isFALSE(Becker)
|
||||
&& isFALSE(Lancefield)
|
||||
&& all(x %in% unlist(reference_df), na.rm = TRUE)) {
|
||||
|
||||
|
||||
reference_df <- repair_reference_df(reference_df)
|
||||
suppressWarnings(
|
||||
y <- data.frame(x = x, stringsAsFactors = FALSE) %pm>%
|
||||
pm_left_join(reference_df, by = "x") %pm>%
|
||||
pm_pull(mo)
|
||||
)
|
||||
|
||||
|
||||
} else if (all(x[!is.na(x)] %in% MO_lookup$mo)
|
||||
& isFALSE(Becker)
|
||||
& isFALSE(Lancefield)) {
|
||||
y <- x
|
||||
|
||||
|
||||
} else {
|
||||
# will be checked for mo class in validation and uses exec_as.mo internally if necessary
|
||||
y <- mo_validate(x = x, property = "mo",
|
||||
@ -282,7 +282,7 @@ exec_as.mo <- function(x,
|
||||
meet_criteria(actual_uncertainty, allow_class = "numeric", has_length = 1)
|
||||
meet_criteria(actual_input, allow_class = "character", allow_NULL = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
if (isTRUE(debug) && initial_search == TRUE) {
|
||||
@ -297,13 +297,13 @@ exec_as.mo <- function(x,
|
||||
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)) {
|
||||
@ -360,19 +360,19 @@ 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
|
||||
x <- replace_old_mo_codes(x, property)
|
||||
# ignore cases that match the ignore pattern
|
||||
x <- replace_ignore_pattern(x, ignore_pattern)
|
||||
|
||||
|
||||
# WHONET: xxx = no growth
|
||||
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
|
||||
# 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"
|
||||
x[trimws2(x) %like% translate_into_language("no .*growth", language = language)] <- NA_character_
|
||||
x[trimws2(x) %like% paste0("^(", translate_into_language("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
|
||||
|
||||
if (initial_search == TRUE) {
|
||||
# keep track of time - give some hints to improve speed if it takes a long time
|
||||
@ -383,7 +383,7 @@ exec_as.mo <- function(x,
|
||||
pkg_env$mo_renamed <- NULL
|
||||
}
|
||||
pkg_env$mo_renamed_last_run <- NULL
|
||||
|
||||
|
||||
failures <- character(0)
|
||||
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
|
||||
uncertainties <- data.frame(uncertainty = integer(0),
|
||||
@ -393,7 +393,7 @@ exec_as.mo <- function(x,
|
||||
mo = character(0),
|
||||
candidates = character(0),
|
||||
stringsAsFactors = FALSE)
|
||||
|
||||
|
||||
x_input <- x
|
||||
# already strip leading and trailing spaces
|
||||
x <- trimws(x)
|
||||
@ -405,7 +405,7 @@ exec_as.mo <- function(x,
|
||||
& !is.null(x)
|
||||
& !identical(x, "")
|
||||
& !identical(x, "xxx")]
|
||||
|
||||
|
||||
# defined df to check for
|
||||
if (!is.null(reference_df)) {
|
||||
check_validity_mo_source(reference_df)
|
||||
@ -420,27 +420,27 @@ exec_as.mo <- function(x,
|
||||
} else {
|
||||
return(rep(NA_character_, length(x_input)))
|
||||
}
|
||||
|
||||
|
||||
} else if (all(x %in% reference_df[, 1][[1]])) {
|
||||
# all in reference df
|
||||
colnames(reference_df)[1] <- "x"
|
||||
suppressWarnings(
|
||||
x <- MO_lookup[match(reference_df[match(x, reference_df$x), "mo", drop = TRUE], MO_lookup$mo), property, drop = TRUE]
|
||||
)
|
||||
|
||||
|
||||
} else if (all(x %in% reference_data_to_use$mo)) {
|
||||
x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
|
||||
|
||||
|
||||
} else if (all(tolower(x) %in% reference_data_to_use$fullname_lower)) {
|
||||
# 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")
|
||||
x <- MO_lookup[match(x, MO_lookup$fullname), property, drop = TRUE]
|
||||
|
||||
|
||||
} else if (all(toupper(x) %in% microorganisms.codes$code)) {
|
||||
# commonly used MO codes
|
||||
x <- MO_lookup[match(microorganisms.codes[match(toupper(x),
|
||||
@ -450,9 +450,9 @@ exec_as.mo <- function(x,
|
||||
MO_lookup$mo),
|
||||
property,
|
||||
drop = TRUE]
|
||||
|
||||
|
||||
} else if (!all(x %in% microorganisms[, property])) {
|
||||
|
||||
|
||||
strip_whitespace <- function(x, dyslexia_mode) {
|
||||
# all whitespaces (tab, new lines, etc.) should be one space
|
||||
# and spaces before and after should be left blank
|
||||
@ -465,7 +465,7 @@ exec_as.mo <- function(x,
|
||||
}
|
||||
trimmed
|
||||
}
|
||||
|
||||
|
||||
x_backup_untouched <- x
|
||||
x <- strip_whitespace(x, dyslexia_mode)
|
||||
# translate 'unknown' names back to English
|
||||
@ -514,7 +514,7 @@ exec_as.mo <- function(x,
|
||||
|
||||
# when ending in SPE instead of SPP and preceded by 2-4 characters
|
||||
x <- gsub("^([a-z]{2,4})(spe.?)$", "\\1", x, perl = TRUE)
|
||||
|
||||
|
||||
x_backup_without_spp <- x
|
||||
# translate to English for supported languages of mo_property
|
||||
x <- gsub("(gruppe|groep|grupo|gruppo|groupe)", "group", x, perl = TRUE)
|
||||
@ -1222,7 +1222,7 @@ exec_as.mo <- function(x,
|
||||
cat(font_bold("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (6) remove non-taxonomic prefix and suffix\n"))
|
||||
}
|
||||
x_without_nontax <- gsub("(^[a-zA-Z]+[./-]+[a-zA-Z]+[^a-zA-Z]* )([a-zA-Z.]+ [a-zA-Z]+.*)",
|
||||
"\\2", a.x_backup, perl = TRUE)
|
||||
"\\2", a.x_backup, perl = TRUE)
|
||||
x_without_nontax <- gsub("( *[(].*[)] *)[^a-zA-Z]*$", "", x_without_nontax, perl = TRUE)
|
||||
if (isTRUE(debug)) {
|
||||
message("Running '", x_without_nontax, "'")
|
||||
@ -1572,15 +1572,15 @@ exec_as.mo <- function(x,
|
||||
# 'MO_CONS' and 'MO_COPS' are <mo> vectors created in R/zzz.R
|
||||
CoNS <- MO_lookup[which(MO_lookup$mo %in% MO_CONS), property, drop = TRUE]
|
||||
x[x %in% CoNS] <- lookup(mo == "B_STPHY_CONS", uncertainty = -1)
|
||||
|
||||
|
||||
CoPS <- MO_lookup[which(MO_lookup$mo %in% MO_COPS), property, drop = TRUE]
|
||||
x[x %in% CoPS] <- lookup(mo == "B_STPHY_COPS", uncertainty = -1)
|
||||
|
||||
|
||||
if (Becker == "all") {
|
||||
x[x %in% lookup(fullname %like_case% "^Staphylococcus aureus", n = Inf)] <- lookup(mo == "B_STPHY_COPS", uncertainty = -1)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Lancefield ----
|
||||
if (Lancefield == TRUE | Lancefield == "all") {
|
||||
# group A - S. pyogenes
|
||||
@ -1602,15 +1602,15 @@ exec_as.mo <- function(x,
|
||||
# group K - S. salivarius
|
||||
x[x %in% lookup(genus == "Streptococcus" & species == "salivarius", n = Inf)] <- lookup(fullname == "Streptococcus group K", uncertainty = -1)
|
||||
}
|
||||
|
||||
|
||||
# Wrap up ----------------------------------------------------------------
|
||||
|
||||
|
||||
# comply to x, which is also unique and without empty values
|
||||
x_input_unique_nonempty <- unique(x_input[!is.na(x_input)
|
||||
& !is.null(x_input)
|
||||
& !identical(x_input, "")
|
||||
& !identical(x_input, "xxx")])
|
||||
|
||||
|
||||
x <- x[match(x_input, x_input_unique_nonempty)]
|
||||
if (property == "mo") {
|
||||
x <- set_clean_class(x, new_class = c("mo", "character"))
|
||||
@ -1618,11 +1618,11 @@ exec_as.mo <- function(x,
|
||||
|
||||
# keep track of time
|
||||
end_time <- Sys.time()
|
||||
|
||||
|
||||
if (length(mo_renamed()) > 0) {
|
||||
print(mo_renamed())
|
||||
}
|
||||
|
||||
|
||||
if (initial_search == FALSE) {
|
||||
# we got here from uncertain_fn().
|
||||
if (NROW(uncertainties) == 0) {
|
||||
@ -1656,7 +1656,7 @@ exec_as.mo <- function(x,
|
||||
if (isTRUE(debug) && initial_search == TRUE) {
|
||||
cat("Finished function", time_track(), "\n")
|
||||
}
|
||||
|
||||
|
||||
x
|
||||
}
|
||||
|
||||
@ -2328,8 +2328,8 @@ as.mo2 <- function(x,
|
||||
# WHONET: xxx = no growth
|
||||
x[tolower(as.character(paste0(x, ""))) %in% c("", "xxx", "na", "nan")] <- NA_character_
|
||||
# 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"
|
||||
x[trimws2(x) %like% translate_into_language("no .*growth", language = language)] <- NA_character_
|
||||
x[trimws2(x) %like% paste0("^(", translate_into_language("no|not", language = language), ") [a-z]+")] <- "UNKNOWN"
|
||||
|
||||
if (initial_search == TRUE) {
|
||||
# keep track of time - give some hints to improve speed if it takes a long time
|
||||
|
||||
@ -178,10 +178,10 @@ mo_name <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "fullname", language = language, ...),
|
||||
language = language,
|
||||
only_unknown = FALSE,
|
||||
only_affect_mo_names = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "fullname", language = language, ...),
|
||||
language = language,
|
||||
only_unknown = FALSE,
|
||||
only_affect_mo_names = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -223,7 +223,7 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
|
||||
|
||||
shortnames[is.na(x.mo)] <- NA_character_
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(shortnames, language = language, only_unknown = FALSE, only_affect_mo_names = TRUE)
|
||||
translate_into_language(shortnames, language = language, only_unknown = FALSE, only_affect_mo_names = TRUE)
|
||||
}
|
||||
|
||||
|
||||
@ -238,7 +238,7 @@ mo_subspecies <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -251,7 +251,7 @@ mo_species <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -264,7 +264,7 @@ mo_genus <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -277,7 +277,7 @@ mo_family <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -290,7 +290,7 @@ mo_order <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -303,7 +303,7 @@ mo_class <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -316,7 +316,7 @@ mo_phylum <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -329,7 +329,7 @@ mo_kingdom <- function(x, language = get_AMR_locale(), ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -349,7 +349,7 @@ mo_type <- function(x, language = get_AMR_locale(), ...) {
|
||||
x.mo <- as.mo(x, language = language, ...)
|
||||
out <- mo_kingdom(x.mo, language = NULL)
|
||||
out[which(mo_is_yeast(x.mo))] <- "Yeasts"
|
||||
translate_AMR(out, language = language, only_unknown = FALSE)
|
||||
translate_into_language(out, language = language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -380,7 +380,7 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
|
||||
| x.mo == "B_GRAMP"] <- "Gram-positive"
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
translate_AMR(x, language = language, only_unknown = FALSE)
|
||||
translate_into_language(x, language = language, only_unknown = FALSE)
|
||||
}
|
||||
|
||||
#' @rdname mo_property
|
||||
@ -435,9 +435,7 @@ mo_is_yeast <- function(x, language = get_AMR_locale(), ...) {
|
||||
metadata <- get_mo_failures_uncertainties_renamed()
|
||||
|
||||
x.kingdom <- mo_kingdom(x.mo, language = NULL)
|
||||
x.phylum <- mo_phylum(x.mo, language = NULL)
|
||||
x.class <- mo_class(x.mo, language = NULL)
|
||||
x.order <- mo_order(x.mo, language = NULL)
|
||||
|
||||
load_mo_failures_uncertainties_renamed(metadata)
|
||||
|
||||
@ -705,7 +703,7 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), .
|
||||
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
|
||||
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
|
||||
translate_AMR(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
|
||||
translate_into_language(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
|
||||
}
|
||||
|
||||
mo_validate <- function(x, property, language, ...) {
|
||||
@ -724,7 +722,7 @@ mo_validate <- function(x, property, language, ...) {
|
||||
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & !has_Becker_or_Lancefield, error = function(e) FALSE)) {
|
||||
# special case for mo_* functions where class is already <mo>
|
||||
x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
|
||||
|
||||
|
||||
} else {
|
||||
# try to catch an error when inputting an invalid argument
|
||||
# so the 'call.' can be set to FALSE
|
||||
|
||||
63
R/plot.R
63
R/plot.R
@ -98,10 +98,10 @@ plot.mic <- function(x,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
@ -149,7 +149,7 @@ plot.mic <- function(x,
|
||||
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
legend = translate_AMR(legend_txt, language = language),
|
||||
legend = translate_into_language(legend_txt, language = language),
|
||||
fill = legend_col,
|
||||
horiz = TRUE,
|
||||
cex = 0.75,
|
||||
@ -185,10 +185,10 @@ barplot.mic <- function(height,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
@ -211,7 +211,7 @@ autoplot.mic <- function(object,
|
||||
mo = NULL,
|
||||
ab = NULL,
|
||||
guideline = "EUCAST",
|
||||
title = paste("MIC values of", deparse(substitute(object))),
|
||||
title = deparse(substitute(object)),
|
||||
ylab = "Frequency",
|
||||
xlab = "Minimum Inhibitory Concentration (mg/L)",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
@ -231,10 +231,10 @@ autoplot.mic <- function(object,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if ("main" %in% names(list(...))) {
|
||||
@ -259,8 +259,8 @@ autoplot.mic <- function(object,
|
||||
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
|
||||
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
|
||||
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
|
||||
df$cols <- factor(translate_AMR(df$cols, language = language),
|
||||
levels = translate_AMR(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
language = language),
|
||||
ordered = TRUE)
|
||||
p <- ggplot2::ggplot(df)
|
||||
@ -270,7 +270,7 @@ autoplot.mic <- function(object,
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Susceptible, incr. exp." = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
names(vals) <- translate_into_language(names(vals), language = language)
|
||||
p <- p +
|
||||
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
|
||||
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
|
||||
@ -321,10 +321,10 @@ plot.disk <- function(x,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
@ -372,7 +372,7 @@ plot.disk <- function(x,
|
||||
}
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
legend = translate_AMR(legend_txt, language = language),
|
||||
legend = translate_into_language(legend_txt, language = language),
|
||||
fill = legend_col,
|
||||
horiz = TRUE,
|
||||
cex = 0.75,
|
||||
@ -408,10 +408,10 @@ barplot.disk <- function(height,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
@ -433,7 +433,7 @@ barplot.disk <- function(height,
|
||||
autoplot.disk <- function(object,
|
||||
mo = NULL,
|
||||
ab = NULL,
|
||||
title = paste("Disk zones of", deparse(substitute(object))),
|
||||
title = deparse(substitute(object)),
|
||||
ylab = "Frequency",
|
||||
xlab = "Disk diffusion diameter (mm)",
|
||||
guideline = "EUCAST",
|
||||
@ -454,10 +454,10 @@ autoplot.disk <- function(object,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if ("main" %in% names(list(...))) {
|
||||
@ -483,8 +483,8 @@ autoplot.disk <- function(object,
|
||||
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
|
||||
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
|
||||
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
|
||||
df$cols <- factor(translate_AMR(df$cols, language = language),
|
||||
levels = translate_AMR(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
|
||||
language = language),
|
||||
ordered = TRUE)
|
||||
p <- ggplot2::ggplot(df)
|
||||
@ -494,7 +494,7 @@ autoplot.disk <- function(object,
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Susceptible, incr. exp." = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
names(vals) <- translate_into_language(names(vals), language = language)
|
||||
p <- p +
|
||||
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
|
||||
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
|
||||
@ -526,11 +526,20 @@ plot.rsi <- function(x,
|
||||
ylab = "Percentage",
|
||||
xlab = "Antimicrobial Interpretation",
|
||||
main = deparse(substitute(x)),
|
||||
language = get_AMR_locale(),
|
||||
...) {
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(xlab, allow_class = "character", has_length = 1)
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||
colnames(data) <- c("x", "n")
|
||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||
@ -592,10 +601,10 @@ barplot.rsi <- function(height,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if (length(colours_RSI) == 1) {
|
||||
@ -620,7 +629,7 @@ barplot.rsi <- function(height,
|
||||
#' @rdname plot
|
||||
# will be exported using s3_register() in R/zzz.R
|
||||
autoplot.rsi <- function(object,
|
||||
title = paste("Resistance Overview of", deparse(substitute(object))),
|
||||
title = deparse(substitute(object)),
|
||||
xlab = "Antimicrobial Interpretation",
|
||||
ylab = "Frequency",
|
||||
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
|
||||
@ -634,10 +643,10 @@ autoplot.rsi <- function(object,
|
||||
|
||||
# translate if not specifically set
|
||||
if (missing(ylab)) {
|
||||
ylab <- translate_AMR(ylab, language = language)
|
||||
ylab <- translate_into_language(ylab, language = language)
|
||||
}
|
||||
if (missing(xlab)) {
|
||||
xlab <- translate_AMR(xlab, language = language)
|
||||
xlab <- translate_into_language(xlab, language = language)
|
||||
}
|
||||
|
||||
if ("main" %in% names(list(...))) {
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
186
R/translate.R
186
R/translate.R
@ -23,21 +23,23 @@
|
||||
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Translate Strings from AMR Package
|
||||
#' Translate Strings from the AMR Package
|
||||
#'
|
||||
#' 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/main/data-raw/translations.tsv>. This file will be read by all functions where a translated output can be desired, like all [`mo_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
|
||||
#' @param x text to translate
|
||||
#' @param lang language to choose. Use one of these supported language names or ISO-639-1 codes: `r paste0('"', names(LANGUAGES_SUPPORTED), '" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", ")`.
|
||||
#' @details The currently `r length(LANGUAGES_SUPPORTED)` supported languages are `r vector_and(names(LANGUAGES_SUPPORTED), quotes = FALSE, sort = FALSE)`. All these languages have translations available for all antimicrobial agents and colloquial microorganism names.
|
||||
#'
|
||||
#' Currently supported languages are: `r vector_and(names(LANGUAGES_SUPPORTED), quotes = FALSE)`. 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).
|
||||
#' Please suggest your own translations [by creating a new issue on our repository](https://github.com/msberends/AMR/issues/new?title=Translations). Strings will be translated to foreign languages if they are defined in [this repository file](https://github.com/msberends/AMR/blob/main/data-raw/translations.tsv). This file will be read by all functions where a translated output can be desired, like all [`mo_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
|
||||
#'
|
||||
#' ## 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:
|
||||
#' The system language will be used at default (as returned by `Sys.getenv("LANG")` or, if `LANG` is not set, [Sys.getlocale("LC_COLLATE")]), 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
|
||||
#' 1. Setting the R option `AMR_locale`, either by using `set_AMR_locale()` or by running e.g. `options(AMR_locale = "de")`.
|
||||
#'
|
||||
#' Note that setting an \R option only works in the same session. Save the command `options(AMR_locale = "(your language)")` to your `.Rprofile` file to apply it for every session.
|
||||
#' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory.
|
||||
#'
|
||||
#' Thus, if the R option `AMR_locale` is set, the system variables `LANGUAGE` and `LANG` will be ignored.
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
@ -45,98 +47,110 @@
|
||||
#' @name translate
|
||||
#' @export
|
||||
#' @examples
|
||||
#' # The 'language' argument of below functions
|
||||
#' # will be set automatically to your system language
|
||||
#' # with get_AMR_locale()
|
||||
#' # Current settings
|
||||
#' ab_name("Ciprofloxacin")
|
||||
#' mo_name("Coagulase-negative Staphylococcus")
|
||||
#'
|
||||
#' # English
|
||||
#' mo_name("CoNS", language = "en")
|
||||
#' #> "Coagulase-negative Staphylococcus (CoNS)"
|
||||
#'
|
||||
#' # Danish
|
||||
#' mo_name("CoNS", language = "da")
|
||||
#' #> "Koagulase-negative stafylokokker (KNS)"
|
||||
#' # setting another language
|
||||
#' set_AMR_locale("Greek")
|
||||
#' ab_name("Ciprofloxacin")
|
||||
#' mo_name("Coagulase-negative Staphylococcus")
|
||||
#'
|
||||
#' # Dutch
|
||||
#' mo_name("CoNS", language = "nl")
|
||||
#' #> "Coagulase-negatieve Staphylococcus (CNS)"
|
||||
#' set_AMR_locale("Spanish")
|
||||
#' ab_name("Ciprofloxacin")
|
||||
#' mo_name("Coagulase-negative Staphylococcus")
|
||||
#'
|
||||
#' # German
|
||||
#' mo_name("CoNS", language = "de")
|
||||
#' #> "Koagulase-negative Staphylococcus (KNS)"
|
||||
#'
|
||||
#' # Italian
|
||||
#' mo_name("CoNS", language = "it")
|
||||
#' #> "Staphylococcus negativo coagulasi (CoNS)"
|
||||
#'
|
||||
#' # Portuguese
|
||||
#' mo_name("CoNS", language = "pt")
|
||||
#' #> "Staphylococcus coagulase negativo (CoNS)"
|
||||
#'
|
||||
#' # Spanish
|
||||
#' mo_name("CoNS", language = "es")
|
||||
#' #> "Staphylococcus coagulasa negativo (SCN)"
|
||||
#' reset_AMR_locale()
|
||||
get_AMR_locale <- function() {
|
||||
# AMR versions 1.3.0 and prior used the environmental variable:
|
||||
if (!identical("", Sys.getenv("AMR_locale"))) {
|
||||
options(AMR_locale = Sys.getenv("AMR_locale"))
|
||||
}
|
||||
|
||||
if (!is.null(getOption("AMR_locale", default = NULL))) {
|
||||
lang <- getOption("AMR_locale")
|
||||
if (lang %in% LANGUAGES_SUPPORTED) {
|
||||
return(lang)
|
||||
} else {
|
||||
stop_("unsupported language set as option 'AMR_locale': \"", lang, "\" - use either ",
|
||||
vector_or(paste0('"', LANGUAGES_SUPPORTED, '" (', names(LANGUAGES_SUPPORTED), ")"), quotes = FALSE))
|
||||
}
|
||||
} else {
|
||||
# now check 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")))
|
||||
}
|
||||
return(validate_language(getOption("AMR_locale"), extra_txt = "set with `options(AMR_locale = ...)`"))
|
||||
}
|
||||
|
||||
# fallback - automatic determination based on LC_COLLATE
|
||||
if (interactive() && message_not_thrown_before("get_AMR_locale", entire_session = TRUE)) {
|
||||
lang <- coerce_language_setting(Sys.getlocale("LC_COLLATE"))
|
||||
if (lang != "en") {
|
||||
message_("Assuming the ", names(LANGUAGES_SUPPORTED)[LANGUAGES_SUPPORTED == lang],
|
||||
" language for the AMR package. Change this with `options(AMR_locale = \"...\")` or see `?get_AMR_locale()`. ",
|
||||
"Supported languages are ", vector_and(names(LANGUAGES_SUPPORTED), quotes = FALSE),
|
||||
". This note will be shown once per session.")
|
||||
}
|
||||
return(lang)
|
||||
lang <- ""
|
||||
# now check the LANGUAGE system variable - return it if set
|
||||
if (!identical("", Sys.getenv("LANGUAGE"))) {
|
||||
lang <- Sys.getenv("LANGUAGE")
|
||||
}
|
||||
coerce_language_setting(Sys.getlocale("LC_COLLATE"))
|
||||
if (!identical("", Sys.getenv("LANG"))) {
|
||||
lang <- Sys.getenv("LANG")
|
||||
}
|
||||
if (lang == "") {
|
||||
lang <- Sys.getlocale("LC_COLLATE")
|
||||
}
|
||||
|
||||
lang <- find_language(lang)
|
||||
if (lang != "en" && interactive() && message_not_thrown_before("get_AMR_locale", entire_session = TRUE)) {
|
||||
message_("Assuming the ", names(LANGUAGES_SUPPORTED)[LANGUAGES_SUPPORTED == lang],
|
||||
" language for the AMR package. Change this with `set_AMR_locale()`. ",
|
||||
"This note will be shown once per session.")
|
||||
}
|
||||
lang
|
||||
}
|
||||
|
||||
coerce_language_setting <- function(lang) {
|
||||
#' @rdname translate
|
||||
#' @export
|
||||
set_AMR_locale <- function(lang) {
|
||||
lang <- validate_language(lang)
|
||||
options(AMR_locale = lang)
|
||||
message_("Using the ", names(LANGUAGES_SUPPORTED)[LANGUAGES_SUPPORTED == lang], " language for the AMR package for this session.")
|
||||
}
|
||||
|
||||
#' @rdname translate
|
||||
#' @export
|
||||
reset_AMR_locale <- function() {
|
||||
options(AMR_locale = NULL)
|
||||
message_("Language for the AMR package reset to English for this session.")
|
||||
}
|
||||
|
||||
#' @rdname translate
|
||||
#' @export
|
||||
translate_AMR <- function(x, language = get_AMR_locale()) {
|
||||
translate_into_language(x, language = language)
|
||||
}
|
||||
|
||||
validate_language <- function(language, extra_txt = character(0)) {
|
||||
language.bak <- language
|
||||
language <- LANGUAGES_SUPPORTED[which(tolower(language) == LANGUAGES_SUPPORTED | tolower(names(LANGUAGES_SUPPORTED)) == tolower(language))][1]
|
||||
stop_ifnot(language %in% LANGUAGES_SUPPORTED,
|
||||
"unsupported language for AMR package", extra_txt, ": \"", language.bak, "\". Use one of these language names or ISO-639-1 codes: ",
|
||||
paste0('"', names(LANGUAGES_SUPPORTED), '" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", "),
|
||||
call = FALSE)
|
||||
unname(language)
|
||||
}
|
||||
|
||||
find_language <- function(lang) {
|
||||
# grepl() with ignore.case = FALSE is 8x faster than %like_case%
|
||||
if (grepl("^(English|en_|EN_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
# as first option to optimise speed
|
||||
"en"
|
||||
} else if (grepl("^(German|Deutsch|de_|DE_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"de"
|
||||
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"nl"
|
||||
} else if (grepl("^(Chinese|zh_|ZH_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"zh"
|
||||
} else if (grepl("^(Danish|Dansk|da_|DA_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"da"
|
||||
} else if (grepl("^(Spanish|Espa.+ol|es_|ES_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"es"
|
||||
} else if (grepl("^(Italian|Italiano|it_|IT_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"it"
|
||||
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"nl"
|
||||
} else if (grepl("^(French|Fran.+ais|fr_|FR_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"fr"
|
||||
} else if (grepl("^(German|Deutsch|de_|DE_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"de"
|
||||
} else if (grepl("^(Greek|el_|EL_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"el"
|
||||
} else if (grepl("^(Italian|Italiano|it_|IT_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"it"
|
||||
} else if (grepl("^(Japanese|ja_|JA_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"ja"
|
||||
} else if (grepl("^(Polish|polsk|pl_|PL_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"pl"
|
||||
} else if (grepl("^(Portuguese|Portugu.+s|pt_|PT_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"pt"
|
||||
} else if (grepl("^(Russian|pycc|ru_|RU_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"ru"
|
||||
} else if (grepl("^(Spanish|Espa.+ol|es_|ES_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"es"
|
||||
} else if (grepl("^(Swedish|Svenskt|sv_|SV_)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"sv"
|
||||
} else if (grepl("^(Ukrainian|uk_|UK)", lang, ignore.case = FALSE, perl = TRUE)) {
|
||||
"uk"
|
||||
} else {
|
||||
# other language -> set to English
|
||||
"en"
|
||||
@ -144,11 +158,11 @@ coerce_language_setting <- function(lang) {
|
||||
}
|
||||
|
||||
# translate strings based on inst/translations.tsv
|
||||
translate_AMR <- function(from,
|
||||
language = get_AMR_locale(),
|
||||
only_unknown = FALSE,
|
||||
only_affect_ab_names = FALSE,
|
||||
only_affect_mo_names = FALSE) {
|
||||
translate_into_language <- function(from,
|
||||
language = get_AMR_locale(),
|
||||
only_unknown = FALSE,
|
||||
only_affect_ab_names = FALSE,
|
||||
only_affect_mo_names = FALSE) {
|
||||
|
||||
if (is.null(language)) {
|
||||
return(from)
|
||||
@ -162,9 +176,13 @@ translate_AMR <- function(from,
|
||||
from_unique <- unique(from)
|
||||
from_unique_translated <- from_unique
|
||||
|
||||
# name of language used
|
||||
language.bak <- language
|
||||
language <- LANGUAGES_SUPPORTED[which(tolower(language) == LANGUAGES_SUPPORTED | tolower(names(LANGUAGES_SUPPORTED)) == tolower(language))][1]
|
||||
|
||||
stop_ifnot(language %in% LANGUAGES_SUPPORTED,
|
||||
"unsupported language: \"", language, "\" - use either ",
|
||||
vector_or(LANGUAGES_SUPPORTED, quotes = TRUE),
|
||||
"unsupported language: \"", language.bak, "\" - use one of these language names or ISO-639-1 codes: ",
|
||||
paste0('"', names(LANGUAGES_SUPPORTED), '" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", "),
|
||||
call = FALSE)
|
||||
|
||||
# only keep lines where translation is available for this language
|
||||
@ -211,7 +229,7 @@ translate_AMR <- function(from,
|
||||
|
||||
# force UTF-8 for diacritics
|
||||
from_unique_translated <- enc2utf8(from_unique_translated)
|
||||
|
||||
|
||||
# a kind of left join to get all results back
|
||||
from_unique_translated[match(from.bak, from_unique)]
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user