AMR/R/ab_property.R

253 lines
9.4 KiB
R
Raw Normal View History

2019-05-10 16:44:59 +02:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2020 Berends MS, Luz CF et al. #
2019-05-10 16:44:59 +02:00
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
2019-05-10 16:44:59 +02:00
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
#' Property of an antibiotic
#'
#' Use these functions to return a specific property of an antibiotic from the [antibiotics] data set. All input values will be evaluated internally with [as.ab()].
2020-05-25 01:01:14 +02:00
#' @inheritSection lifecycle Stable lifecycle
#' @param x any (vector of) text that can be coerced to a valid microorganism code with [as.ab()]
2019-05-10 16:44:59 +02:00
#' @param tolower logical to indicate whether the first character of every output should be transformed to a lower case character. This will lead to e.g. "polymyxin B" and not "polymyxin b".
#' @param property one of the column names of one of the [antibiotics] data set
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
#' @param administration way of administration, either `"oral"` or `"iv"`
2019-05-10 16:44:59 +02:00
#' @param units a logical to indicate whether the units instead of the DDDs itself must be returned, see Examples
#' @param open browse the URL using [utils::browseURL()]
#' @param ... other parameters passed on to [as.ab()]
#' @details All output will be [translate]d where possible.
#'
2020-05-25 01:01:14 +02:00
#' 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.
2019-05-10 16:44:59 +02:00
#' @inheritSection as.ab Source
#' @rdname ab_property
#' @name ab_property
#' @return
#' - An [`integer`] in case of [ab_cid()]
#' - A named [`list`] in case of [ab_info()] and multiple [ab_synonyms()]/[ab_tradenames()]
#' - A [`double`] in case of [ab_ddd()]
#' - A [`character`] in all other cases
2019-05-10 16:44:59 +02:00
#' @export
#' @seealso [antibiotics]
2019-05-10 16:44:59 +02:00
#' @inheritSection AMR Read more on our website!
#' @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_tradenames("AMX") # same
#' 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
2019-05-10 16:44:59 +02:00
#'
2020-01-26 20:20:00 +01:00
#' # smart lowercase tranformation
2019-05-10 16:44:59 +02:00
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
#' ab_name(x = c("AMC", "PLB"),
#' tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
#'
2020-01-26 20:20:00 +01:00
#' # defined daily doses (DDD)
2019-05-10 16:44:59 +02:00
#' ab_ddd("AMX", "oral") # 1
#' ab_ddd("AMX", "oral", units = TRUE) # "g"
#' ab_ddd("AMX", "iv") # 1
#' ab_ddd("AMX", "iv", units = TRUE) # "g"
#'
2019-05-16 21:20:00 +02:00
#' ab_info("AMX") # all properties as a list
#'
2020-01-26 20:20:00 +01:00
#' # 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)
#'
#' # spelling from different languages and dyslexia are no problem
#' ab_atc("ceftriaxon")
#' ab_atc("cephtriaxone")
#' ab_atc("cephthriaxone")
#' ab_atc("seephthriaaksone")
2019-05-10 16:44:59 +02:00
ab_name <- function(x, language = get_locale(), tolower = FALSE, ...) {
2019-06-11 14:18:25 +02:00
x <- translate_AMR(ab_validate(x = x, property = "name", ...), language = language)
2019-05-10 16:44:59 +02:00
if (tolower == TRUE) {
# use perl to only transform the first character
# as we want "polymyxin B", not "polymyxin b"
2019-06-11 14:18:25 +02:00
x <- gsub("^([A-Z])", "\\L\\1", x, perl = TRUE)
2019-05-10 16:44:59 +02:00
}
2019-06-11 14:18:25 +02:00
x
2019-05-10 16:44:59 +02:00
}
#' @rdname ab_property
2019-11-06 14:43:23 +01:00
#' @aliases ATC
2019-05-10 16:44:59 +02:00
#' @export
ab_atc <- function(x, ...) {
ab_validate(x = x, property = "atc", ...)
}
#' @rdname ab_property
#' @export
ab_cid <- function(x, ...) {
ab_validate(x = x, property = "cid", ...)
}
#' @rdname ab_property
#' @export
ab_synonyms <- function(x, ...) {
syns <- ab_validate(x = x, property = "synonyms", ...)
names(syns) <- x
if (length(syns) == 1) {
unname(unlist(syns))
} else {
syns
}
}
#' @rdname ab_property
#' @export
ab_tradenames <- function(x, ...) {
ab_synonyms(x, ...)
}
#' @rdname ab_property
#' @export
2019-05-16 21:20:00 +02:00
ab_group <- function(x, language = get_locale(), ...) {
2019-06-11 14:18:25 +02:00
translate_AMR(ab_validate(x = x, property = "group", ...), language = language)
2019-05-10 16:44:59 +02:00
}
#' @rdname ab_property
#' @export
2019-05-16 21:20:00 +02:00
ab_atc_group1 <- function(x, language = get_locale(), ...) {
2019-06-11 14:18:25 +02:00
translate_AMR(ab_validate(x = x, property = "atc_group1", ...), language = language)
2019-05-10 16:44:59 +02:00
}
#' @rdname ab_property
#' @export
2019-05-16 21:20:00 +02:00
ab_atc_group2 <- function(x, language = get_locale(), ...) {
2019-06-11 14:18:25 +02:00
translate_AMR(ab_validate(x = x, property = "atc_group2", ...), language = language)
2019-05-10 16:44:59 +02:00
}
2020-01-26 20:20:00 +01:00
#' @rdname ab_property
#' @export
ab_loinc <- function(x, ...) {
loincs <- ab_validate(x = x, property = "loinc", ...)
names(loincs) <- x
if (length(loincs) == 1) {
unname(unlist(loincs))
} else {
loincs
}
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
if (!administration %in% c("oral", "iv")) {
stop("`administration` must be 'oral' or 'iv'", call. = FALSE)
}
ddd_prop <- administration
if (units == TRUE) {
ddd_prop <- paste0(ddd_prop, "_units")
} else {
ddd_prop <- paste0(ddd_prop, "_ddd")
}
ab_validate(x = x, property = ddd_prop, ...)
}
2019-05-16 22:07:31 +02:00
#' @rdname ab_property
#' @export
2019-05-16 21:20:00 +02:00
ab_info <- function(x, language = get_locale(), ...) {
2020-02-14 19:54:13 +01:00
x <- as.ab(x, ...)
2019-06-11 14:18:25 +02:00
base::list(ab = as.character(x),
2019-06-27 11:57:45 +02:00
atc = ab_atc(x),
2019-05-16 21:20:00 +02:00
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_url <- function(x, open = FALSE, ...) {
ab <- as.ab(x = x, ... = ...)
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", ab_atc(ab), "&showdescription=no")
u[is.na(ab_atc(ab))] <- NA_character_
names(u) <- ab_name(ab)
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(ab_atc(ab))]
if (length(NAs) > 0) {
warning("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
}
if (open == TRUE) {
if (length(u) > 1 & !is.na(u[1L])) {
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
}
if (!is.na(u[1L])) {
utils::browseURL(u[1L])
}
}
u
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
2019-10-11 17:21:02 +02:00
ab_property <- function(x, property = "name", language = get_locale(), ...) {
2019-05-10 16:44:59 +02:00
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}
2020-02-14 19:54:13 +01:00
if (!property %in% colnames(antibiotics)) {
2019-05-10 16:44:59 +02:00
stop("invalid property: '", property, "' - use a column name of the `antibiotics` data set")
}
2019-06-11 14:18:25 +02:00
translate_AMR(ab_validate(x = x, property = property, ...), language = language)
2019-05-10 16:44:59 +02:00
}
ab_validate <- function(x, property, ...) {
2020-02-14 19:54:13 +01:00
check_dataset_integrity()
2019-05-10 16:44:59 +02:00
# try to catch an error when inputting an invalid parameter
# so the 'call.' can be set to FALSE
2020-02-14 19:54:13 +01:00
tryCatch(x[1L] %in% antibiotics[1, property],
2019-05-10 16:44:59 +02:00
error = function(e) stop(e$message, call. = FALSE))
x_bak <- x
2020-02-14 19:54:13 +01:00
if (!all(x %in% antibiotics[, property])) {
x <- data.frame(ab = as.ab(x, ...), stringsAsFactors = FALSE) %>%
left_join(antibiotics, by = "ab") %>%
2019-05-10 16:44:59 +02:00
pull(property)
}
2019-06-27 11:57:45 +02:00
if (property == "ab") {
2019-05-10 16:44:59 +02:00
return(structure(x, class = property))
} else if (property == "cid") {
return(as.integer(x))
} else if (property %like% "ddd") {
return(as.double(x))
} else {
x[is.na(x) & !is.na(x_bak)] <- NA
2019-05-10 16:44:59 +02:00
return(x)
}
}