mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 02:03:04 +02:00
styled, unit test fix
This commit is contained in:
259
R/ab_property.R
259
R/ab_property.R
@ -9,7 +9,7 @@
|
||||
# (c) 2018-2022 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
@ -37,14 +37,14 @@
|
||||
#' @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.
|
||||
#'
|
||||
#'
|
||||
#' The function [ab_url()] will return the direct URL to the official WHO website. A warning will be returned if the required ATC code is not available.
|
||||
#'
|
||||
#'
|
||||
#' The function [set_ab_names()] is a special column renaming function for [data.frame]s. It renames columns names that resemble antimicrobial drugs. It always makes sure that the new column names are unique. If `property = "atc"` is set, preference is given to ATC codes from the J-group.
|
||||
#' @inheritSection as.ab Source
|
||||
#' @rdname ab_property
|
||||
#' @name ab_property
|
||||
#' @return
|
||||
#' @return
|
||||
#' - An [integer] in case of [ab_cid()]
|
||||
#' - A named [list] in case of [ab_info()] and multiple [ab_atc()]/[ab_synonyms()]/[ab_tradenames()]
|
||||
#' - A [double] in case of [ab_ddd()]
|
||||
@ -55,43 +55,45 @@
|
||||
#' @inheritSection AMR Reference Data Publicly Available
|
||||
#' @examples
|
||||
#' # all properties:
|
||||
#' ab_name("AMX") # "Amoxicillin"
|
||||
#' ab_atc("AMX") # "J01CA04" (ATC code from the WHO)
|
||||
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
|
||||
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
|
||||
#' ab_name("AMX") # "Amoxicillin"
|
||||
#' ab_atc("AMX") # "J01CA04" (ATC code from the WHO)
|
||||
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
|
||||
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
|
||||
#' ab_tradenames("AMX") # same
|
||||
#' ab_group("AMX") # "Beta-lactams/penicillins"
|
||||
#' ab_group("AMX") # "Beta-lactams/penicillins"
|
||||
#' ab_atc_group1("AMX") # "Beta-lactam antibacterials, penicillins"
|
||||
#' ab_atc_group2("AMX") # "Penicillins with extended spectrum"
|
||||
#' ab_url("AMX") # link to the official WHO page
|
||||
#' ab_url("AMX") # link to the official WHO page
|
||||
#'
|
||||
#' # smart lowercase tranformation
|
||||
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
|
||||
#' ab_name(x = c("AMC", "PLB"),
|
||||
#' tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
|
||||
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
|
||||
#' ab_name(
|
||||
#' x = c("AMC", "PLB"),
|
||||
#' tolower = TRUE
|
||||
#' ) # "amoxicillin/clavulanic acid" "polymyxin B"
|
||||
#'
|
||||
#' # defined daily doses (DDD)
|
||||
#' ab_ddd("AMX", "oral") # 1.5
|
||||
#' ab_ddd("AMX", "oral") # 1.5
|
||||
#' ab_ddd_units("AMX", "oral") # "g"
|
||||
#' ab_ddd("AMX", "iv") # 3
|
||||
#' ab_ddd_units("AMX", "iv") # "g"
|
||||
#' ab_ddd("AMX", "iv") # 3
|
||||
#' ab_ddd_units("AMX", "iv") # "g"
|
||||
#'
|
||||
#' ab_info("AMX") # all properties as a list
|
||||
#' ab_info("AMX") # all properties as a list
|
||||
#'
|
||||
#' # all ab_* functions use as.ab() internally, so you can go from 'any' to 'any':
|
||||
#' ab_atc("AMP") # ATC code of AMP (ampicillin)
|
||||
#' ab_group("J01CA01") # Drug group of ampicillins ATC code
|
||||
#' ab_loinc("ampicillin") # LOINC codes of ampicillin
|
||||
#' ab_name("21066-6") # "Ampicillin" (using LOINC)
|
||||
#' ab_name(6249) # "Ampicillin" (using CID)
|
||||
#' ab_name("J01CA01") # "Ampicillin" (using ATC)
|
||||
#'
|
||||
#' ab_atc("AMP") # ATC code of AMP (ampicillin)
|
||||
#' ab_group("J01CA01") # Drug group of ampicillins ATC code
|
||||
#' ab_loinc("ampicillin") # LOINC codes of ampicillin
|
||||
#' ab_name("21066-6") # "Ampicillin" (using LOINC)
|
||||
#' ab_name(6249) # "Ampicillin" (using CID)
|
||||
#' ab_name("J01CA01") # "Ampicillin" (using ATC)
|
||||
#'
|
||||
#' # spelling from different languages and dyslexia are no problem
|
||||
#' ab_atc("ceftriaxon")
|
||||
#' ab_atc("cephtriaxone")
|
||||
#' ab_atc("cephthriaxone")
|
||||
#' ab_atc("seephthriaaksone")
|
||||
#'
|
||||
#'
|
||||
#' # use set_ab_names() for renaming columns
|
||||
#' colnames(example_isolates)
|
||||
#' colnames(set_ab_names(example_isolates))
|
||||
@ -101,31 +103,31 @@
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names() %>%
|
||||
#' head()
|
||||
#'
|
||||
#'
|
||||
#' # this does the same:
|
||||
#' example_isolates %>%
|
||||
#' rename_with(set_ab_names)%>%
|
||||
#' rename_with(set_ab_names) %>%
|
||||
#' head()
|
||||
#'
|
||||
#'
|
||||
#' # set_ab_names() works with any AB property:
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(property = "atc")%>%
|
||||
#' set_ab_names(property = "atc") %>%
|
||||
#' head()
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(where(is.rsi)) %>%
|
||||
#' colnames()
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(NIT:VAN) %>%
|
||||
#' colnames()
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(where(is.rsi)) %>%
|
||||
#' colnames()
|
||||
#'
|
||||
#' example_isolates %>%
|
||||
#' set_ab_names(NIT:VAN) %>%
|
||||
#' colnames()
|
||||
#' }
|
||||
#' }
|
||||
ab_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
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_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
|
||||
@ -176,27 +178,29 @@ ab_group <- function(x, language = get_AMR_locale(), ...) {
|
||||
ab_atc <- function(x, only_first = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(only_first, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
atcs <- ab_validate(x = x, property = "atc", ...)
|
||||
|
||||
|
||||
if (only_first == TRUE) {
|
||||
atcs <- vapply(FUN.VALUE = character(1),
|
||||
# get only the first ATC code
|
||||
atcs,
|
||||
function(x) {
|
||||
# try to get the J-group
|
||||
if (any(x %like% "^J")) {
|
||||
x[x %like% "^J"][1L]
|
||||
} else {
|
||||
as.character(x[1L])
|
||||
}
|
||||
})
|
||||
atcs <- vapply(
|
||||
FUN.VALUE = character(1),
|
||||
# get only the first ATC code
|
||||
atcs,
|
||||
function(x) {
|
||||
# try to get the J-group
|
||||
if (any(x %like% "^J")) {
|
||||
x[x %like% "^J"][1L]
|
||||
} else {
|
||||
as.character(x[1L])
|
||||
}
|
||||
}
|
||||
)
|
||||
} else if (length(atcs) == 1) {
|
||||
atcs <- unname(unlist(atcs))
|
||||
} else {
|
||||
names(atcs) <- x
|
||||
}
|
||||
|
||||
|
||||
atcs
|
||||
}
|
||||
|
||||
@ -234,26 +238,30 @@ ab_loinc <- function(x, ...) {
|
||||
ab_ddd <- function(x, administration = "oral", ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
|
||||
|
||||
|
||||
x <- as.ab(x, ...)
|
||||
ddd_prop <- administration
|
||||
# old behaviour
|
||||
units <- list(...)$units
|
||||
if (!is.null(units) && isTRUE(units)) {
|
||||
if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
|
||||
warning_("in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
|
||||
"This warning will be shown once per session.")
|
||||
warning_(
|
||||
"in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
|
||||
"This warning will be shown once per session."
|
||||
)
|
||||
}
|
||||
ddd_prop <- paste0(ddd_prop, "_units")
|
||||
} else {
|
||||
ddd_prop <- paste0(ddd_prop, "_ddd")
|
||||
}
|
||||
out <- ab_validate(x = x, property = ddd_prop)
|
||||
|
||||
|
||||
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_("in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"www.whocc.no/ddd/list_of_ddds_combined_products/")
|
||||
warning_(
|
||||
"in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"www.whocc.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
}
|
||||
out
|
||||
}
|
||||
@ -263,14 +271,16 @@ ab_ddd <- function(x, administration = "oral", ...) {
|
||||
ab_ddd_units <- function(x, administration = "oral", ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
|
||||
|
||||
|
||||
x <- as.ab(x, ...)
|
||||
if (any(ab_name(x, language = NULL) %like% "/")) {
|
||||
warning_("in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"www.whocc.no/ddd/list_of_ddds_combined_products/")
|
||||
warning_(
|
||||
"in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"www.whocc.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
ddd_prop <- paste0(administration, "_units")
|
||||
ab_validate(x = x, property = ddd_prop)
|
||||
}
|
||||
@ -280,21 +290,29 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
|
||||
ab_info <- 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)
|
||||
|
||||
|
||||
x <- as.ab(x, ...)
|
||||
list(ab = as.character(x),
|
||||
cid = ab_cid(x),
|
||||
name = ab_name(x, language = language),
|
||||
group = ab_group(x, language = language),
|
||||
atc = ab_atc(x),
|
||||
atc_group1 = ab_atc_group1(x, language = language),
|
||||
atc_group2 = ab_atc_group2(x, language = language),
|
||||
tradenames = ab_tradenames(x),
|
||||
loinc = ab_loinc(x),
|
||||
ddd = list(oral = list(amount = ab_ddd(x, administration = "oral"),
|
||||
units = ab_ddd_units(x, administration = "oral")),
|
||||
iv = list(amount = ab_ddd(x, administration = "iv"),
|
||||
units = ab_ddd_units(x, administration = "iv"))))
|
||||
list(
|
||||
ab = as.character(x),
|
||||
cid = ab_cid(x),
|
||||
name = ab_name(x, language = language),
|
||||
group = ab_group(x, language = language),
|
||||
atc = ab_atc(x),
|
||||
atc_group1 = ab_atc_group1(x, language = language),
|
||||
atc_group2 = ab_atc_group2(x, language = language),
|
||||
tradenames = ab_tradenames(x),
|
||||
loinc = ab_loinc(x),
|
||||
ddd = list(
|
||||
oral = list(
|
||||
amount = ab_ddd(x, administration = "oral"),
|
||||
units = ab_ddd_units(x, administration = "oral")
|
||||
),
|
||||
iv = list(
|
||||
amount = ab_ddd(x, administration = "iv"),
|
||||
units = ab_ddd_units(x, administration = "iv")
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
@ -303,18 +321,18 @@ ab_info <- function(x, language = get_AMR_locale(), ...) {
|
||||
ab_url <- function(x, open = FALSE, ...) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(open, allow_class = "logical", has_length = 1)
|
||||
|
||||
|
||||
ab <- as.ab(x = x, ...)
|
||||
atcs <- ab_atc(ab, only_first = TRUE)
|
||||
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", atcs, "&showdescription=no")
|
||||
u[is.na(atcs)] <- NA_character_
|
||||
names(u) <- ab_name(ab)
|
||||
|
||||
|
||||
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
|
||||
if (length(NAs) > 0) {
|
||||
warning_("in `ab_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
||||
}
|
||||
|
||||
|
||||
if (open == TRUE) {
|
||||
if (length(u) > 1 & !is.na(u[1L])) {
|
||||
warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
|
||||
@ -343,17 +361,17 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
||||
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)) {
|
||||
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
|
||||
df <- pm_select(data, ...)
|
||||
@ -370,44 +388,50 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
||||
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)
|
||||
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_("in `set_ab_names()`: no ", property, " found for column(s): ",
|
||||
vector_and(vars[x %in% c("", NA)], sort = FALSE))
|
||||
warning_(
|
||||
"in `set_ab_names()`: no ", property, " found for column(s): ",
|
||||
vector_and(vars[x %in% c("", NA)], sort = 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)))
|
||||
}
|
||||
}))
|
||||
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
|
||||
@ -419,25 +443,24 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
||||
}
|
||||
|
||||
ab_validate <- function(x, property, ...) {
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
if (tryCatch(all(x[!is.na(x)] %in% AB_lookup$ab), error = function(e) FALSE)) {
|
||||
# special case for ab_* functions where class is already <ab>
|
||||
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
|
||||
|
||||
} else {
|
||||
# try to catch an error when inputting an invalid argument
|
||||
# so the 'call.' can be set to FALSE
|
||||
tryCatch(x[1L] %in% antibiotics[1, property, drop = TRUE],
|
||||
error = function(e) stop(e$message, call. = FALSE))
|
||||
|
||||
error = function(e) stop(e$message, call. = FALSE)
|
||||
)
|
||||
|
||||
if (!all(x %in% AB_lookup[, property, drop = TRUE])) {
|
||||
x <- as.ab(x, ...)
|
||||
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (property == "ab") {
|
||||
return(set_clean_class(x, new_class = c("ab", "character")))
|
||||
} else if (property == "cid") {
|
||||
|
||||
Reference in New Issue
Block a user