# ==================================================================== # # TITLE: # # AMR: An R Package for Working with Antimicrobial Resistance Data # # # # SOURCE CODE: # # https://github.com/msberends/AMR # # # # PLEASE CITE THIS SOFTWARE AS: # # Berends MS, Luz CF, Friedrich AW, et al. (2022). # # AMR: An R Package for Working with Antimicrobial Resistance Data. # # Journal of Statistical Software, 104(3), 1-31. # # https://doi.org/10.18637/jss.v104.i03 # # # # Developed at the University of Groningen and the University Medical # # Center Groningen in The Netherlands, in collaboration with many # # colleagues from around the world, see our website. # # # # 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. # # # # Visit our website for the full manual and a complete tutorial about # # how to conduct AMR data analysis: https://msberends.github.io/AMR/ # # ==================================================================== # #' Get Properties 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()]. #' @param x any (vector of) text that can be coerced to a valid antibiotic drug code with [as.ab()] #' @param tolower a [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: `vector_or(colnames(antibiotics), sort = FALSE)`. #' @param language language of the returned text - the default is the current system language (see [get_AMR_locale()]) and can also be set with the package option [`AMR_locale`][AMR-options]. Use `language = NULL` or `language = ""` to prevent translation. #' @param administration way of administration, either `"oral"` or `"iv"` #' @param open browse the URL using [utils::browseURL()] #' @param ... in case of [set_ab_names()] and `data` is a [data.frame]: columns to select (supports tidy selection such as `column1:column4`), otherwise other arguments passed on to [as.ab()] #' @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. #' #' 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 #' - 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()] #' - A [data.frame] in case of [set_ab_names()] #' - A [character] in all other cases #' @export #' @seealso [antibiotics] #' @inheritSection AMR Reference Data Publicly Available #' @examples #' # all properties: #' ab_name("AMX") #' ab_atc("AMX") #' ab_cid("AMX") #' ab_synonyms("AMX") #' ab_tradenames("AMX") #' ab_group("AMX") #' ab_atc_group1("AMX") #' ab_atc_group2("AMX") #' ab_url("AMX") #' #' # smart lowercase transformation #' ab_name(x = c("AMC", "PLB")) #' ab_name(x = c("AMC", "PLB"), tolower = TRUE) #' #' # defined daily doses (DDD) #' ab_ddd("AMX", "oral") #' ab_ddd_units("AMX", "oral") #' ab_ddd("AMX", "iv") #' ab_ddd_units("AMX", "iv") #' #' 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") #' ab_group("J01CA01") #' ab_loinc("ampicillin") #' ab_name("21066-6") #' ab_name(6249) #' ab_name("J01CA01") #' #' # 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)) #' colnames(set_ab_names(example_isolates, NIT:VAN)) #' \donttest{ #' 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(property = "atc") #' #' example_isolates %>% #' set_ab_names(where(is.sir)) %>% #' 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) language <- validate_language(language) 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 # as we want "polymyxin B", not "polymyxin b" x <- gsub("^([A-Z])", "\\L\\1", x, perl = TRUE) } x } #' @rdname ab_property #' @export ab_cid <- function(x, ...) { meet_criteria(x, allow_NA = TRUE) ab_validate(x = x, property = "cid", ...) } #' @rdname ab_property #' @export ab_synonyms <- function(x, ...) { meet_criteria(x, allow_NA = TRUE) 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, ...) { meet_criteria(x, allow_NA = TRUE) ab_synonyms(x, ...) } #' @rdname ab_property #' @export ab_group <- function(x, language = get_AMR_locale(), ...) { meet_criteria(x, allow_NA = TRUE) language <- validate_language(language) translate_into_language(ab_validate(x = x, property = "group", ...), language = language, only_affect_ab_names = TRUE) } #' @rdname ab_property #' @aliases ATC #' @export 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]) } } ) } else if (length(atcs) == 1) { atcs <- unname(unlist(atcs)) } else { names(atcs) <- x } atcs } #' @rdname ab_property #' @export ab_atc_group1 <- function(x, language = get_AMR_locale(), ...) { meet_criteria(x, allow_NA = TRUE) language <- validate_language(language) translate_into_language(ab_validate(x = x, property = "atc_group1", ...), language = language, only_affect_ab_names = TRUE) } #' @rdname ab_property #' @export ab_atc_group2 <- function(x, language = get_AMR_locale(), ...) { meet_criteria(x, allow_NA = TRUE) language <- validate_language(language) translate_into_language(ab_validate(x = x, property = "atc_group2", ...), language = language, only_affect_ab_names = TRUE) } #' @rdname ab_property #' @export ab_loinc <- function(x, ...) { meet_criteria(x, allow_NA = TRUE) loincs <- ab_validate(x = x, property = "loinc", ...) names(loincs) <- x if (length(loincs) == 1) { unname(unlist(loincs)) } else { loincs } } #' @rdname ab_property #' @export 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 <- paste0(administration, "_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", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) } out } #' @rdname ab_property #' @export 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, ...) ddd_prop <- paste0(administration, "_units") out <- ab_validate(x = x, property = ddd_prop) if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) { warning_( "in `ab_ddd_units()`: 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", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) } out } #' @rdname ab_property #' @export ab_info <- function(x, language = get_AMR_locale(), ...) { meet_criteria(x, allow_NA = TRUE) language <- validate_language(language) 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") ) ) ) } #' @rdname ab_property #' @export 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 <- character(length(atcs)) # veterinary codes u[atcs %like% "^Q"] <- paste0("https://atcddd.fhi.no/atcvet/atcvet_index/?code=", atcs[atcs %like% "^Q"], "&showdescription=no") u[atcs %unlike% "^Q"] <- paste0("https://atcddd.fhi.no/atc_ddd_index//?code=", atcs[atcs %unlike% "^Q"], "&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.") } if (!is.na(u[1L])) { utils::browseURL(u[1L]) } } u } #' @rdname ab_property #' @export ab_property <- function(x, property = "name", language = get_AMR_locale(), ...) { meet_criteria(x, allow_NA = TRUE) meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1) language <- validate_language(language) translate_into_language(ab_validate(x = x, property = property, ...), language = language) } #' @rdname ab_property #' @aliases ATC #' @export set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale(), snake_case = NULL) { meet_criteria(data, allow_class = c("data.frame", "character")) meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1, ignore.case = TRUE) language <- validate_language(language) 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(c(...)) > 1, error = function(e) TRUE)) { df <- tryCatch(suppressWarnings(pm_select(data, ...)), error = function(e) { data[, c(...), drop = FALSE] } ) } else if (tryCatch(is.character(c(...)), error = function(e) FALSE)) { df <- data[, c(...), drop = FALSE] } else { df <- data } vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names") if (length(vars) == 0) { message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.") return(data) } } else { # quickly get antibiotic drug 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_( "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 (anyDuplicated(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], "_", 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, ...) { if (tryCatch(all(x[!is.na(x)] %in% AMR_env$AB_lookup$ab), error = function(e) FALSE)) { # special case for ab_* functions where class is already 'ab' x <- AMR_env$AB_lookup[match(x, AMR_env$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% AMR_env$AB_lookup[1, property, drop = TRUE], error = function(e) stop(e$message, call. = FALSE) ) if (!all(x %in% AMR_env$AB_lookup[, property, drop = TRUE])) { x <- as.ab(x, ...) if (all(is.na(x)) && is.list(AMR_env$AB_lookup[, property, drop = TRUE])) { x <- rep(NA_character_, length(x)) } else { x <- AMR_env$AB_lookup[match(x, AMR_env$AB_lookup$ab), property, drop = TRUE] } } } if (property == "ab") { return(set_clean_class(x, new_class = c("ab", "character"))) } else if (property == "cid") { return(as.integer(x)) } else if (property %like% "ddd") { return(as.double(x)) } else { x[is.na(x)] <- NA return(x) } }