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

(v1.7.1.9040) Support for Danish

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-09-29 12:12:35 +02:00
parent 5f433d6e5c
commit 93a4734b44
62 changed files with 911 additions and 823 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
R/ab.R
View File

@ -118,7 +118,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# remove diacritics
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
x <- gsub('"', "", x, fixed = TRUE)
x <- gsub("(specimen|specimen date|specimen_date|spec_date|^dates?$)", "", x, ignore.case = TRUE, perl = TRUE)
x <- gsub("(specimen|specimen date|specimen_date|spec_date|gender|^dates?$)", "", x, ignore.case = TRUE, perl = TRUE)
x_bak_clean <- x
if (already_regex == FALSE) {
x_bak_clean <- generalise_antibiotic_name(x_bak_clean)
@ -443,7 +443,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
# take failed ATC codes apart from rest
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0) {
if (length(x_unknown_ATCs) > 0 & fast_mode == FALSE) {
warning_("These ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), ".",
call = FALSE)

146
R/ab_property.R
View File

@ -34,7 +34,7 @@
#' @param administration way of administration, either `"oral"` or `"iv"`
#' @param open browse the URL using [utils::browseURL()]
#' @param ... other arguments passed on to [as.ab()]
#' @param data a [data.frame] of which the columns need to be renamed
#' @param data a [data.frame] of which the columns need to be renamed, or a [character] vector of column names
#' @param snake_case a [logical] to indicate whether the names should be in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`)
#' @param only_first a [logical] to indicate whether only the first ATC code must be returned, with giving preference to J0-codes (i.e., the antimicrobial drug group)
#' @details All output [will be translated][translate] where possible.
@ -101,6 +101,11 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' set_ab_names()
#'
#' # this does the same:
#' example_isolates %>%
#' rename_with(set_ab_names)
#'
#' # set_ab_names() works with any AB property:
#' example_isolates %>%
#' set_ab_names("atc")
@ -120,68 +125,6 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
x
}
#' @rdname ab_property
#' @aliases ATC
#' @export
set_ab_names <- function(data, property = "name", language = get_locale(), snake_case = property == "name") {
meet_criteria(data, allow_class = "data.frame")
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1, ignore.case = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(snake_case, allow_class = "logical", has_length = 1)
x_deparsed <- deparse(substitute(data))
if (length(x_deparsed) > 1 || any(x_deparsed %unlike% "[a-z]+")) {
x_deparsed <- "your_data"
}
property <- tolower(property)
columns <- get_column_abx(data, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
if (length(columns) == 0) {
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
return(data)
}
x <- vapply(FUN.VALUE = character(1),
ab_property(columns, property = property, language = language),
function(x) {
if (property == "atc") {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
} else {
as.character(x[1L])
}
})
if (any(x %in% c("", NA))) {
warning_("No ", property, " found for column(s): ", vector_and(columns[x %in% c("", NA)], sort = FALSE), call = FALSE)
x[x %in% c("", NA)] <- columns[x %in% c("", NA)]
}
if (snake_case == TRUE) {
x <- tolower(gsub("[^a-zA-Z0-9]+", "_", x))
}
if (any(duplicated(x))) {
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
invisible(lapply(unique(x),
function(u) {
dups <- which(x == u)
if (length(dups) > 1) {
# there are duplicates
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
}
}))
}
colnames(data)[colnames(data) %in% columns] <- x
data
}
#' @rdname ab_property
#' @export
ab_cid <- function(x, ...) {
@ -382,6 +325,83 @@ ab_property <- function(x, property = "name", language = get_locale(), ...) {
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
}
#' @rdname ab_property
#' @aliases ATC
#' @export
set_ab_names <- function(data, property = "name", language = get_locale(), snake_case = NULL) {
meet_criteria(data, allow_class = c("data.frame", "character"))
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1, ignore.case = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(snake_case, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
x_deparsed <- deparse(substitute(data))
if (length(x_deparsed) > 1 || any(x_deparsed %unlike% "[a-z]+")) {
x_deparsed <- "your_data"
}
property <- tolower(property)
if (is.null(snake_case)) {
snake_case <- property == "name"
}
if (is.data.frame(data)) {
vars <- get_column_abx(data, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
if (length(vars) == 0) {
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
return(data)
}
} else {
# quickly get antibiotic codes
vars_ab <- as.ab(data, fast_mode = TRUE)
vars <- data[!is.na(vars_ab)]
}
x <- vapply(FUN.VALUE = character(1),
ab_property(vars, property = property, language = language),
function(x) {
if (property == "atc") {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
} else {
as.character(x[1L])
}
},
USE.NAMES = FALSE)
if (any(x %in% c("", NA))) {
warning_("No ", property, " found for column(s): ", vector_and(vars[x %in% c("", NA)], sort = FALSE), call = FALSE)
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
}
if (snake_case == TRUE) {
x <- tolower(gsub("[^a-zA-Z0-9]+", "_", x))
}
if (any(duplicated(x))) {
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
invisible(lapply(unique(x),
function(u) {
dups <- which(x == u)
if (length(dups) > 1) {
# there are duplicates
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
}
}))
}
if (is.data.frame(data)) {
colnames(data)[colnames(data) %in% vars] <- x
data
} else {
data[which(!is.na(vars_ab))] <- x
data
}
}
ab_validate <- function(x, property, ...) {
check_dataset_integrity()

2
R/rsi.R
View File

@ -310,6 +310,8 @@ as.rsi.default <- function(x, ...) {
# remove everything between brackets, and 'high' and 'low'
x <- gsub("([(].*[)])", "", x)
x <- gsub("(high|low)", "", x, ignore.case = TRUE)
# some labs now report "H" instead of "I" to not interfere with EUCAST prior to 2019
x <- gsub("H", "I", x, ignore.case = TRUE)
# disallow more than 3 characters
x[nchar(x) > 3] <- NA
# set to capitals

BIN
R/sysdata.rda
View File

Binary file not shown.

22
R/translate.R
View File

@ -29,7 +29,7 @@
#' @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_*`][mo_property()] functions (such as [mo_name()], [mo_gramstain()], [mo_type()], etc.) and [`ab_*`][ab_property()] functions (such as [ab_name()], [ab_group()], etc.).
#'
#' Currently supported languages are: `r vector_and(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"]), quotes = FALSE)`. Please note that currently not all these languages have translations available for all antimicrobial agents and colloquial microorganism names.
#' Currently supported languages are: `r vector_and(gsub(";.*", "", ISOcodes::ISO_639_2[which(ISOcodes::ISO_639_2$Alpha_2 %in% LANGUAGES_SUPPORTED), "Name"]), 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).
#'
@ -53,17 +53,17 @@
#' mo_name("CoNS", language = "en")
#' #> "Coagulase-negative Staphylococcus (CoNS)"
#'
#' # German
#' mo_name("CoNS", language = "de")
#' #> "Koagulase-negative Staphylococcus (KNS)"
#'
#' # Danish
#' mo_name("CoNS", language = "nl")
#' #> "Koagulase-negative stafylokokker (CoNS)"
#'
#' # Dutch
#' mo_name("CoNS", language = "nl")
#' #> "Coagulase-negatieve Staphylococcus (CNS)"
#'
#' # Spanish
#' mo_name("CoNS", language = "es")
#' #> "Staphylococcus coagulasa negativo (SCN)"
#' # German
#' mo_name("CoNS", language = "de")
#' #> "Koagulase-negative Staphylococcus (KNS)"
#'
#' # Italian
#' mo_name("CoNS", language = "it")
@ -72,6 +72,10 @@
#' # Portuguese
#' mo_name("CoNS", language = "pt")
#' #> "Staphylococcus coagulase negativo (CoNS)"
#'
#' # Spanish
#' mo_name("CoNS", language = "es")
#' #> "Staphylococcus coagulasa negativo (SCN)"
get_locale <- function() {
# AMR versions 1.3.0 and prior used the environmental variable:
if (!identical("", Sys.getenv("AMR_locale"))) {
@ -108,6 +112,8 @@ coerce_language_setting <- function(lang) {
"de"
} else if (grepl("^(Dutch|Nederlands|nl_|NL_)", lang, ignore.case = FALSE, perl = TRUE)) {
"nl"
} 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)) {