P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-11 10:21:54 +02:00
Code Releases Activity

ab_info, other bug fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-05-16 21:20:00 +02:00
parent f6bf54b37d
commit 4c3cf85a65
57 changed files with 519 additions and 430 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
R/ab.R
View File

@ -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")

36
R/ab_property.R
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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)