mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 13:01:59 +02:00
ab_info, other bug fixes
This commit is contained in:
47
R/ab.R
47
R/ab.R
@ -52,7 +52,7 @@
|
||||
#' as.ab(" eryt 123")
|
||||
#' as.ab("ERYT")
|
||||
#' as.ab("ERY")
|
||||
#' as.ab("erytromicine") # spelled wrong
|
||||
#' as.ab("eritromicine") # spelled wrong, yet works
|
||||
#' as.ab("Erythrocin") # trade name
|
||||
#' as.ab("Romycin") # trade name
|
||||
#'
|
||||
@ -64,13 +64,20 @@ as.ab <- function(x) {
|
||||
if (is.ab(x)) {
|
||||
return(x)
|
||||
}
|
||||
|
||||
if (all(toupper(x) %in% AMR::antibiotics$ab)) {
|
||||
# valid AB code, but not yet right class
|
||||
return(structure(.Data = toupper(x),
|
||||
class = "ab"))
|
||||
}
|
||||
|
||||
x_bak <- x
|
||||
# remove suffices
|
||||
x_bak_clean <- gsub("_(mic|rsi|disk|disc)$", "", x)
|
||||
x_bak_clean <- gsub("_(mic|rsi|disk|disc)$", "", x, ignore.case = TRUE)
|
||||
# remove disk concentrations, like LVX_NM -> LVX
|
||||
x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean, ignore.case = TRUE)
|
||||
# clean rest of it
|
||||
x_bak_clean <- gsub("[^a-zA-Z0-9/-]", "", x_bak_clean)
|
||||
x_bak_clean <- gsub("[^A-Z0-9/-]", "", x_bak_clean, ignore.case = TRUE)
|
||||
# keep only a-z when it's not an ATC code or only numbers
|
||||
x_bak_clean[!x_bak_clean %like% "^([A-Z][0-9]{2}[A-Z]{2}[0-9]{2}|[0-9]+)$"] <- gsub("[^a-zA-Z]+",
|
||||
"",
|
||||
@ -156,19 +163,25 @@ as.ab <- function(x) {
|
||||
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
|
||||
next
|
||||
}
|
||||
x_spelling <- x[i]
|
||||
x_spelling <- gsub("[iy]+", "[iy]+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("[sz]+", "[sz]+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("(c|k|q|qu)+", "(c|k|q|qu)+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("(ph|f|v)+", "(ph|f|v)+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("(th|t)+", "(th|t)+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("a+", "a+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("e+", "e+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("o+", "o+", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- tolower(x[i])
|
||||
x_spelling <- gsub("[iy]+", "[iy]+", x_spelling)
|
||||
x_spelling <- gsub("[sz]+", "[sz]+", x_spelling)
|
||||
x_spelling <- gsub("(c|k|q|qu)+", "(c|k|q|qu)+", x_spelling)
|
||||
x_spelling <- gsub("(ph|f|v)+", "(ph|f|v)+", x_spelling)
|
||||
x_spelling <- gsub("(th|t)+", "(th|t)+", x_spelling)
|
||||
x_spelling <- gsub("(x|ks)+", "(x|ks)+", x_spelling)
|
||||
x_spelling <- gsub("a+", "a+", x_spelling)
|
||||
x_spelling <- gsub("e+", "e+", x_spelling)
|
||||
x_spelling <- gsub("o+", "o+", x_spelling)
|
||||
# allow start with C/S/Z
|
||||
x_spelling <- gsub("^(\\(c\\|k\\|q\\|qu\\)|\\[sz\\])", "(c|k|q|qu|s|z)", x_spelling)
|
||||
x_spelling <- gsub("(c|k|q|qu)+[sz]", "(c|k|q|qu|s|x|z)", x_spelling, fixed = TRUE)
|
||||
# allow any ending of -in/-ine and -im/-ime
|
||||
x_spelling <- gsub("(\\[iy\\]\\+(n|m)|\\[iy\\]\\+(n|m)e\\+)$", "[iy]+(n|m)e*", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("(\\[iy\\]\\+(n|m)|\\[iy\\]\\+(n|m)e\\+)$", "[iy]+(n|m)e*", x_spelling)
|
||||
# allow any ending of -ol/-ole
|
||||
x_spelling <- gsub("(o\\+l|o\\+le\\+)$", "o+le*", x_spelling, ignore.case = TRUE)
|
||||
x_spelling <- gsub("(o\\+l|o\\+le\\+)$", "o+le*", x_spelling)
|
||||
# allow any ending of -on/-one
|
||||
x_spelling <- gsub("(o\\+n|o\\+ne\\+)$", "o+ne*", x_spelling)
|
||||
# try if name starts with it
|
||||
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab
|
||||
if (length(found) > 0) {
|
||||
@ -203,11 +216,15 @@ as.ab <- function(x) {
|
||||
left_join(data.frame(x = x, x_new = x_new, stringsAsFactors = FALSE), by = "x") %>%
|
||||
pull(x_new)
|
||||
|
||||
if (length(x_result) == 0) {
|
||||
x_result <- NA_character_
|
||||
}
|
||||
|
||||
structure(.Data = x_result,
|
||||
class = "ab")
|
||||
}
|
||||
|
||||
#' @rdname as.atc
|
||||
#' @rdname as.ab
|
||||
#' @export
|
||||
is.ab <- function(x) {
|
||||
identical(class(x), "ab")
|
||||
|
@ -35,7 +35,7 @@
|
||||
#' @name ab_property
|
||||
#' @return \itemize{
|
||||
#' \item{An \code{integer} in case of \code{ab_cid}}
|
||||
#' \item{A named \code{list} in case of multiple \code{ab_synonyms}}
|
||||
#' \item{A named \code{list} in case of \code{ab_info} and multiple \code{ab_synonyms}/\code{ab_tradenames}}
|
||||
#' \item{A \code{double} in case of \code{ab_ddd}}
|
||||
#' \item{A \code{character} in all other cases}
|
||||
#' }
|
||||
@ -64,6 +64,8 @@
|
||||
#' ab_ddd("AMX", "iv") # 1
|
||||
#' ab_ddd("AMX", "iv", units = TRUE) # "g"
|
||||
#'
|
||||
#' ab_info("AMX") # all properties as a list
|
||||
#'
|
||||
#' # all ab_* functions use as.ab() internally:
|
||||
#' ab_name("Fluclox") # "Flucloxacillin"
|
||||
#' ab_name("fluklox") # "Flucloxacillin"
|
||||
@ -113,20 +115,20 @@ ab_tradenames <- function(x, ...) {
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_group <- function(x, ...) {
|
||||
ab_validate(x = x, property = "group", ...)
|
||||
ab_group <- function(x, language = get_locale(), ...) {
|
||||
t(ab_validate(x = x, property = "group", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_atc_group1 <- function(x, ...) {
|
||||
ab_validate(x = x, property = "atc_group1", ...)
|
||||
ab_atc_group1 <- function(x, language = get_locale(), ...) {
|
||||
t(ab_validate(x = x, property = "atc_group1", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_atc_group2 <- function(x, ...) {
|
||||
ab_validate(x = x, property = "atc_group2", ...)
|
||||
ab_atc_group2 <- function(x, language = get_locale(), ...) {
|
||||
t(ab_validate(x = x, property = "atc_group2", ...), language = language)
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
@ -144,6 +146,22 @@ ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
|
||||
ab_validate(x = x, property = ddd_prop, ...)
|
||||
}
|
||||
|
||||
ab_info <- function(x, language = get_locale(), ...) {
|
||||
x <- AMR::as.ab(x, ...)
|
||||
base::list(ab = x,
|
||||
atc = ab_atc(x),
|
||||
cid = ab_cid(x),
|
||||
name = ab_name(x, language = language),
|
||||
group = ab_group(x, language = language),
|
||||
atc_group1 = ab_atc_group1(x, language = language),
|
||||
atc_group2 = ab_atc_group2(x, language = language),
|
||||
tradenames = ab_tradenames(x),
|
||||
ddd = list(oral = list(amount = ab_ddd(x, administration = "oral", units = FALSE),
|
||||
units = ab_ddd(x, administration = "oral", units = TRUE)),
|
||||
iv = list(amount = ab_ddd(x, administration = "iv", units = FALSE),
|
||||
units = ab_ddd(x, administration = "iv", units = TRUE))))
|
||||
}
|
||||
|
||||
#' @rdname ab_property
|
||||
#' @export
|
||||
ab_property <- function(x, property = 'name', language = get_locale(), ...) {
|
||||
@ -169,8 +187,8 @@ ab_validate <- function(x, property, ...) {
|
||||
error = function(e) stop(e$message, call. = FALSE))
|
||||
|
||||
if (!all(x %in% AMR::antibiotics[, property])) {
|
||||
x <- data.frame(ab = as.ab(x), stringsAsFactors = FALSE) %>%
|
||||
left_join(antibiotics %>% select(c("ab", property)), by = "ab") %>%
|
||||
x <- data.frame(ab = AMR::as.ab(x), stringsAsFactors = FALSE) %>%
|
||||
left_join(AMR::antibiotics, by = "ab") %>%
|
||||
pull(property)
|
||||
}
|
||||
if (property %in% c("ab", "atc")) {
|
||||
|
2
R/atc.R
2
R/atc.R
@ -33,7 +33,7 @@
|
||||
#'
|
||||
#' In the ATC classification system, the active substances are classified in a hierarchy with five different levels. The system has fourteen main anatomical/pharmacological groups or 1st levels. Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups. The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance. The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
|
||||
#' Source: \url{https://www.whocc.no/atc/structure_and_principles/}
|
||||
#' @return Character (vector) with class \code{"act"}. Unknown values will return \code{NA}.
|
||||
#' @return Character (vector) with class \code{"atc"}. Unknown values will return \code{NA}.
|
||||
#' @seealso \code{\link{antibiotics}} for the dataframe that is being used to determine ATCs.
|
||||
#' @inheritSection AMR Read more on our website!
|
||||
#' @examples
|
||||
|
28
R/freq.R
28
R/freq.R
@ -250,7 +250,8 @@ frequency_tbl <- function(x,
|
||||
if (length(user_exprs) > 0) {
|
||||
new_list <- list(0)
|
||||
for (i in 1:length(user_exprs)) {
|
||||
new_list[[i]] <- eval_tidy(user_exprs[[i]], data = x)
|
||||
new_list[[i]] <- tryCatch(eval_tidy(user_exprs[[i]], data = x),
|
||||
error = function(e) stop(e$message, call. = FALSE))
|
||||
if (length(new_list[[i]]) == 1) {
|
||||
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
|
||||
# support septic_patients %>% freq("hospital_id")
|
||||
@ -330,8 +331,27 @@ frequency_tbl <- function(x,
|
||||
cols <- NULL
|
||||
# mult.columns <- 2
|
||||
} else {
|
||||
x.name <- NULL
|
||||
cols <- NULL
|
||||
x.name <- deparse(substitute(x))
|
||||
if (x.name %like% "[$]") {
|
||||
cols <- unlist(strsplit(x.name, "$", fixed = TRUE))[2]
|
||||
x.name <- unlist(strsplit(x.name, "$", fixed = TRUE))[1]
|
||||
# try to find the object to determine dimensions
|
||||
x.obj <- tryCatch(get(x.name), error = function(e) NULL)
|
||||
x.name <- paste0("`", x.name , "`")
|
||||
if (!is.null(x.obj)) {
|
||||
x.name <- paste0(x.name,
|
||||
" (",
|
||||
x.obj %>%
|
||||
dim() %>%
|
||||
format(decimal.mark = decimal.mark, big.mark = big.mark) %>%
|
||||
trimws() %>%
|
||||
paste(collapse = " x "),
|
||||
")")
|
||||
}
|
||||
} else {
|
||||
x.name <- NULL
|
||||
cols <- NULL
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.null(ncol(x))) {
|
||||
@ -566,7 +586,7 @@ format_header <- function(x, markdown = FALSE, decimal.mark = ".", big.mark = ",
|
||||
# rsi
|
||||
if (has_length == TRUE & any(x_class == "rsi")) {
|
||||
ab <- tryCatch(as.ab(attributes(x)$opt$vars), error = function(e) NA)
|
||||
if (!is.na(ab)) {
|
||||
if (!is.na(ab) & isTRUE(length(ab) > 0)) {
|
||||
header$drug <- paste0(ab_name(ab[1L]), " (", ab[1L], ", ", ab_atc(ab[1L]), ")")
|
||||
header$group <- ab_group(ab[1L])
|
||||
}
|
||||
|
9
R/misc.R
9
R/misc.R
@ -390,9 +390,12 @@ t <- function(from, language = get_locale()) {
|
||||
df_trans$fixed[is.na(df_trans$fixed)] <- TRUE
|
||||
|
||||
# check if text to look for is in one of the patterns
|
||||
pattern_total <- tryCatch(paste0("(", paste(df_trans$pattern, collapse = "|"), ")"),
|
||||
error = "")
|
||||
if (NROW(df_trans) == 0 | !any(from %like% pattern_total)) {
|
||||
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)
|
||||
}
|
||||
|
||||
|
1
R/mo.R
1
R/mo.R
@ -349,6 +349,7 @@ exec_as.mo <- function(x,
|
||||
|
||||
# conversion of old MO codes from v0.5.0 (ITIS) to later versions (Catalogue of Life)
|
||||
if (any(x %like% "^[BFP]_[A-Z]{3,7}") & !all(x %in% microorganisms$mo)) {
|
||||
x <- gsub("^F_CANDD_GLB$", "F_CANDD_GLA", x) # specific old code for C. glabrata
|
||||
leftpart <- gsub("^([BFP]_[A-Z]{3,7}).*", "\\1", x)
|
||||
if (any(leftpart %in% names(mo_codes_v0.5.0))) {
|
||||
rightpart <- gsub("^[BFP]_[A-Z]{3,7}(.*)", "\\1", x)
|
||||
|
Reference in New Issue
Block a user