P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 08:52:15 +02:00
Code Releases Activity

(v0.7.1.9072) key_antibiotics() for foreign systems

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-09-12 15:08:53 +02:00
parent b5d2a08401
commit cd178ee569
28 changed files with 1640 additions and 119 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
R/age.R
View File

@ -145,6 +145,10 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
if (!is.numeric(x)) {
stop("`x` and must be numeric, not a ", paste0(class(x), collapse = "/"), ".")
}
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning("NAs introduced for ages below 0.")
}
if (is.character(split_at)) {
split_at <- split_at[1L]
if (split_at %like% "^(child|kid|junior)") {

2
R/atc_online.R
View File

@ -81,7 +81,7 @@ atc_online_property <- function(atc_code,
}
if (!all(atc_code %in% AMR::antibiotics)) {
atc_code <- as.character(as.atc(atc_code))
atc_code <- as.character(ab_atc(atc_code))
}
if (!curl::has_internet()) {

25
R/key_antibiotics.R
View File

@ -184,25 +184,28 @@ key_antibiotics <- function(x,
# join to microorganisms data set
x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>%
mutate_at(vars(col_mo), as.mo) %>%
left_join_microorganisms(by = col_mo) %>%
mutate(key_ab = NA_character_,
gramstain = mo_gramstain(pull(., col_mo)))
gramstain = mo_gramstain(pull(., col_mo), language = NULL))
# Gram +
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram-positive",
apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
tryCatch(apply(X = x[, gram_positive],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
key_ab))
# Gram -
x <- x %>% mutate(key_ab =
if_else(gramstain == "Gram-negative",
apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
tryCatch(apply(X = x[, gram_negative],
MARGIN = 1,
FUN = function(x) paste(x, collapse = "")),
error = function(e) paste0(rep(".", 12), collapse = "")),
key_ab))
# format
@ -211,6 +214,10 @@ key_antibiotics <- function(x,
gsub('(NA|NULL)', '.', .) %>%
gsub('[^SIR]', '.', ., ignore.case = TRUE) %>%
toupper()
if (n_distinct(key_abs) == 1) {
warning("No distinct key antibiotics determined.", call. = FALSE)
}
key_abs

12
R/like.R
View File

@ -56,8 +56,16 @@
like <- function(x, pattern) {
if (length(pattern) > 1) {
if (length(x) != length(pattern)) {
pattern <- pattern[1]
warning('only the first element of argument `pattern` used for `%like%`', call. = TRUE)
if (length(x) == 1) {
x <- rep(x, length(pattern))
}
# return TRUE for every 'x' that matches any 'pattern', FALSE otherwise
res <- sapply(pattern, function(pttrn) x %like% pttrn)
res2 <- as.logical(rowSums(res))
# get only first item of every hit in pattern
res2[duplicated(res)] <- FALSE
res2[rowSums(res) == 0] <- NA
return(res2)
} else {
# x and pattern are of same length, so items with each other
res <- vector(length = length(pattern))

55
R/misc.R
View File

@ -123,61 +123,6 @@ stopifnot_installed_package <- function(package) {
return(invisible())
}
# translate strings based on inst/translations.tsv
#' @importFrom dplyr %>% filter
translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
# if (getOption("AMR_locale", "en") != language) {
# language <- getOption("AMR_locale", "en")
# }
if (is.null(language)) {
return(from)
}
if (language %in% c("en", "")) {
return(from)
}
df_trans <- translations_file # internal data file
if (!language %in% df_trans$lang) {
stop("Unsupported language: '", language, "' - use one of: ",
paste0("'", sort(unique(df_trans$lang)), "'", collapse = ", "),
call. = FALSE)
}
df_trans <- df_trans %>% filter(lang == language)
if (only_unknown == TRUE) {
df_trans <- df_trans %>% filter(pattern %like% "unknown")
}
# default case sensitive if value if 'ignore.case' is missing:
df_trans$ignore.case[is.na(df_trans$ignore.case)] <- FALSE
# default not using regular expressions (fixed = TRUE) if 'fixed' is missing:
df_trans$fixed[is.na(df_trans$fixed)] <- TRUE
# check if text to look for is in one of the patterns
any_form_in_patterns <- tryCatch(any(from %like% paste0("(", paste(df_trans$pattern, collapse = "|"), ")")),
error = function(e) {
warning("Translation not possible. Please open an issue on GitLab (https://gitlab.com/msberends/AMR/issues) or GitHub (https://github.com/msberends/AMR/issues).", call. = FALSE)
return(FALSE)
})
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
return(from)
}
for (i in 1:nrow(df_trans)) {
from <- gsub(x = from,
pattern = df_trans$pattern[i],
replacement = df_trans$replacement[i],
fixed = df_trans$fixed[i],
ignore.case = df_trans$ignore.case[i])
}
# force UTF-8 for diacritics
base::enc2utf8(from)
}
"%or%" <- function(x, y) {
if (is.null(x) | is.null(y)) {
if (is.null(x)) {

52
R/mo.R
View File

@ -432,13 +432,13 @@ exec_as.mo <- function(x,
}
x <- y
} else if (all(x %in% read_mo_history(uncertainty_level,
force = force_mo_history)$x)) {
# previously found code
x <- microorganismsDT[data.table(mo = get_mo_history(x,
uncertainty_level,
force = force_mo_history)),
on = "mo", ..property][[1]]
# } else if (all(x %in% read_mo_history(uncertainty_level,
# force = force_mo_history)$x)) {
# # previously found code
# x <- microorganismsDT[data.table(mo = get_mo_history(x,
# uncertainty_level,
# force = force_mo_history)),
# on = "mo", ..property][[1]]
} else if (all(tolower(x) %in% microorganismsDT$fullname_lower)) {
# we need special treatment for very prevalent full names, they are likely!
@ -561,17 +561,17 @@ exec_as.mo <- function(x,
progress$tick()$print()
if (initial_search == TRUE) {
found <- microorganismsDT[mo == get_mo_history(x_backup[i],
uncertainty_level,
force = force_mo_history),
..property][[1]]
# previously found result
if (length(found) > 0) {
x[i] <- found[1L]
next
}
}
# if (initial_search == TRUE) {
# found <- microorganismsDT[mo == get_mo_history(x_backup[i],
# uncertainty_level,
# force = force_mo_history),
# ..property][[1]]
# # previously found result
# if (length(found) > 0) {
# x[i] <- found[1L]
# next
# }
# }
found <- microorganismsDT[mo == toupper(x_backup[i]), ..property][[1]]
# is a valid MO code
@ -826,6 +826,7 @@ exec_as.mo <- function(x,
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history)
}
next
} else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup_without_spp[i], ignore.case = FALSE)) {
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
x[i] <- microorganismsDT[mo == 'B_SLMNL_ENT', ..property][[1]][1L]
@ -833,11 +834,11 @@ exec_as.mo <- function(x,
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history)
}
uncertainties <- rbind(uncertainties,
data.frame(uncertainty_level = 1,
input = x_backup_without_spp[i],
result_mo = "B_SLMNL_ENT"))
format_uncertainty_as_df(uncertainty_level = 1,
input = x_backup_without_spp[i],
result_mo = "B_SLMNL_ENT"))
next
}
next
}
# trivial names known to the field:
@ -1850,8 +1851,11 @@ mo_renamed <- function() {
#' @export
#' @noRd
print.mo_renamed <- function(x, ...) {
items <- getOption("mo_renamed")
base::message(blue(paste("NOTE:", names(items), "was renamed", items, collapse = "\n"), collapse = "\n"))
items <- x #getOption("mo_renamed")
old <- names(x)
new <- x
cat(blue(paste("NOTE:", italic(names(items)), "was renamed", italic(items), collapse = "\n"), collapse = "\n"))
}
nr2char <- function(x) {

1489
R/mo2.R Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
R/sysdata.rda
View File

Binary file not shown.

55
R/get_locale.R → R/translate.R
View File

@ -64,7 +64,7 @@
#' mo_name("CoNS", language = "pt")
#' #> "Staphylococcus coagulase negativo (CoNS)"
get_locale <- function() {
if (getOption("AMR_locale", "en") != "en") {
if (!is.null(getOption("AMR_locale", default = NULL))) {
return(getOption("AMR_locale"))
}
@ -73,6 +73,7 @@ get_locale <- function() {
# Check the locale settings for a start with one of these languages:
# 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"
@ -93,3 +94,55 @@ get_locale <- function() {
"en"
}
}
# translate strings based on inst/translations.tsv
#' @importFrom dplyr %>% filter
translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
if (is.null(language)) {
return(from)
}
if (language %in% c("en", "", NA)) {
return(from)
}
df_trans <- translations_file # internal data file
if (!language %in% df_trans$lang) {
stop("Unsupported language: '", language, "' - use one of: ",
paste0("'", sort(unique(df_trans$lang)), "'", collapse = ", "),
call. = FALSE)
}
df_trans <- df_trans %>% filter(lang == language)
if (only_unknown == TRUE) {
df_trans <- df_trans %>% filter(pattern %like% "unknown")
}
# default case sensitive if value if 'ignore.case' is missing:
df_trans$ignore.case[is.na(df_trans$ignore.case)] <- FALSE
# default not using regular expressions (fixed = TRUE) if 'fixed' is missing:
df_trans$fixed[is.na(df_trans$fixed)] <- TRUE
# check if text to look for is in one of the patterns
any_form_in_patterns <- tryCatch(any(from %like% paste0("(", paste(df_trans$pattern, collapse = "|"), ")")),
error = function(e) {
warning("Translation not possible. Please open an issue on GitLab (https://gitlab.com/msberends/AMR/issues) or GitHub (https://github.com/msberends/AMR/issues).", call. = FALSE)
return(FALSE)
})
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
return(from)
}
for (i in 1:nrow(df_trans)) {
from <- gsub(x = from,
pattern = df_trans$pattern[i],
replacement = df_trans$replacement[i],
fixed = df_trans$fixed[i],
ignore.case = df_trans$ignore.case[i])
}
# force UTF-8 for diacritics
base::enc2utf8(from)
}