(v1.7.1.9024) unit tests

R/aa_helper_functions.R

@@ -520,9 +520,9 @@ create_eucast_ab_documentation <- function() {
   x <- trimws(unique(toupper(unlist(strsplit(EUCAST_RULES_DF$then_change_these_antibiotics, ",")))))
   ab <- character()
   for (val in x) {
-    if (val %in% ls(envir = asNamespace("AMR"))) {
+    if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
       # antibiotic group names, as defined in data-raw/_internals.R, such as `CARBAPENEMS`
-      val <- eval(parse(text = val), envir = asNamespace("AMR"))
+      val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
     } else if (val %in% AB_lookup$ab) {
       # separate drugs, such as `AMX`
       val <- as.ab(val)
@@ -532,7 +532,7 @@ create_eucast_ab_documentation <- function() {
     ab <- c(ab, val)
   }
   ab <- unique(ab)
-  atcs <- ab_atc(ab)
+  atcs <- ab_atc(ab, only_first = TRUE)
   # only keep ABx with an ATC code:
   ab <- ab[!is.na(atcs)]
   ab_names <- ab_name(ab, language = NULL, tolower = TRUE)
@@ -949,7 +949,7 @@ font_grey <- function(..., collapse = " ") {
   try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
 }
 font_grey_bg <- function(..., collapse = " ") {
-  if (tryCatch(rstudioapi::getThemeInfo()$dark == TRUE, error = function(e) FALSE)) {
+  if (tryCatch(import_fn("getThemeInfo", "rstudioapi", error_on_fail = FALSE)()$dark, error = function(e) FALSE)) {
     # similar to HTML #444444
     try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse)  
   } else {

R/ab_class_selectors.R

@@ -31,6 +31,7 @@
 #' @param filter an [expression] to be evaluated in the [antibiotics] data set, such as `name %like% "trim"`
 #' @param only_rsi_columns a [logical] to indicate whether only columns of class `<rsi>` must be selected (defaults to `FALSE`), see [as.rsi()]
 #' @param only_treatable a [logical] to indicate whether agents that are only for laboratory tests should be excluded (defaults to `TRUE`), such as gentamicin-high (`GEH`) and imipenem/EDTA (`IPE`)
+#' @param ... ignored, only in place to allow future extensions
 #' @details
 #' These functions can be used in data set calls for selecting columns and filtering rows. They are heavily inspired by the [Tidyverse selection helpers][tidyselect::language] such as [`everything()`][tidyselect::everything()], but also work in base \R and not only in `dplyr` verbs. Nonetheless, they are very convenient to use with `dplyr` functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()], see *Examples*.
 #' 
@@ -153,7 +154,8 @@
 #' }
 ab_class <- function(ab_class, 
                      only_rsi_columns = FALSE,
-                     only_treatable = TRUE) {
+                     only_treatable = TRUE,
+                     ...) {
   meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
@@ -164,7 +166,8 @@ ab_class <- function(ab_class,
 #' @export
 ab_selector <- function(filter, 
                         only_rsi_columns = FALSE,
-                        only_treatable = TRUE) {
+                        only_treatable = TRUE,
+                        ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
   
@@ -188,7 +191,7 @@ ab_selector <- function(filter,
 
 #' @rdname antibiotic_class_selectors
 #' @export
-administrable_per_os <- function(only_rsi_columns = FALSE) {
+administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   # get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
   # but it only takes a couple of milliseconds
@@ -215,7 +218,7 @@ administrable_per_os <- function(only_rsi_columns = FALSE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-administrable_iv <- function(only_rsi_columns = FALSE) {
+administrable_iv <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   # get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
   # but it only takes a couple of milliseconds
@@ -236,7 +239,7 @@ administrable_iv <- function(only_rsi_columns = FALSE) {
 # nolint start
 # #' @rdname antibiotic_class_selectors
 # #' @export
-# not_intrinsic_resistant <- function(mo, ..., only_rsi_columns = FALSE) {
+# not_intrinsic_resistant <- function(mo, ..., only_rsi_columns = FALSE, ...) {
 #   meet_criteria(mo, allow_class = c("mo", "data.frame", "list", "character", "numeric", "integer", "factor"), has_length = 1, allow_NA = FALSE)
 #   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
 # 
@@ -272,7 +275,7 @@ administrable_iv <- function(only_rsi_columns = FALSE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
+aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
   ab_select_exec("aminoglycosides", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
@@ -280,28 +283,28 @@ aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-aminopenicillins <- function(only_rsi_columns = FALSE) {
+aminopenicillins <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("aminopenicillins", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-antifungals <- function(only_rsi_columns = FALSE) {
+antifungals <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_select_exec("antifungals", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
+  ab_select_exec("antifungals", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-antimycobacterials <- function(only_rsi_columns = FALSE) {
+antimycobacterials <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_select_exec("antimycobacterials", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
+  ab_select_exec("antimycobacterials", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
+betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
   ab_select_exec("betalactams", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
@@ -309,7 +312,7 @@ betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-carbapenems <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
+carbapenems <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
   ab_select_exec("carbapenems", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
@@ -317,98 +320,98 @@ carbapenems <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins <- function(only_rsi_columns = FALSE) {
+cephalosporins <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins_1st <- function(only_rsi_columns = FALSE) {
+cephalosporins_1st <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins_1st", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins_2nd <- function(only_rsi_columns = FALSE) {
+cephalosporins_2nd <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins_2nd", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins_3rd <- function(only_rsi_columns = FALSE) {
+cephalosporins_3rd <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins_3rd", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins_4th <- function(only_rsi_columns = FALSE) {
+cephalosporins_4th <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins_4th", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-cephalosporins_5th <- function(only_rsi_columns = FALSE) {
+cephalosporins_5th <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("cephalosporins_5th", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-fluoroquinolones <- function(only_rsi_columns = FALSE) {
+fluoroquinolones <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("fluoroquinolones", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-glycopeptides <- function(only_rsi_columns = FALSE) {
+glycopeptides <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("glycopeptides", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-lincosamides <- function(only_rsi_columns = FALSE) {
+lincosamides <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("lincosamides", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-lipoglycopeptides <- function(only_rsi_columns = FALSE) {
+lipoglycopeptides <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("lipoglycopeptides", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-macrolides <- function(only_rsi_columns = FALSE) {
+macrolides <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("macrolides", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-oxazolidinones <- function(only_rsi_columns = FALSE) {
+oxazolidinones <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("oxazolidinones", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-penicillins <- function(only_rsi_columns = FALSE) {
+penicillins <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("penicillins", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-polymyxins <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
+polymyxins <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
   ab_select_exec("polymyxins", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
@@ -416,35 +419,35 @@ polymyxins <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-streptogramins <- function(only_rsi_columns = FALSE) {
+streptogramins <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("streptogramins", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-quinolones <- function(only_rsi_columns = FALSE) {
+quinolones <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("quinolones", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-tetracyclines <- function(only_rsi_columns = FALSE) {
+tetracyclines <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("tetracyclines", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-trimethoprims <- function(only_rsi_columns = FALSE) {
+trimethoprims <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("trimethoprims", only_rsi_columns = only_rsi_columns)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-ureidopenicillins <- function(only_rsi_columns = FALSE) {
+ureidopenicillins <- function(only_rsi_columns = FALSE, ...) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
   ab_select_exec("ureidopenicillins", only_rsi_columns = only_rsi_columns)
 }

R/ab_property.R

@@ -36,6 +36,7 @@
 #' @param ... other arguments passed on to [as.ab()]
 #' @param data a [data.frame] of which the columns need to be renamed
 #' @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.
@@ -57,7 +58,7 @@
 #' @examples
 #' # all properties:
 #' ab_name("AMX")       # "Amoxicillin"
-#' ab_atc("AMX")        # J01CA04 (ATC code from the WHO)
+#' 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
@@ -181,20 +182,6 @@ set_ab_names <- function(data, property = "name", language = get_locale(), snake
   data
 }
 
-#' @rdname ab_property
-#' @aliases ATC
-#' @export
-ab_atc <- function(x, ...) {
-  meet_criteria(x, allow_NA = TRUE)
-  atcs <- ab_validate(x = x, property = "atc", ...)
-  names(atcs) <- x
-  if (length(atcs) == 1) {
-    unname(unlist(atcs))
-  } else {
-    atcs
-  }
-}
-
 #' @rdname ab_property
 #' @export
 ab_cid <- function(x, ...) {
@@ -230,6 +217,36 @@ ab_group <- function(x, language = get_locale(), ...) {
   translate_AMR(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_locale(), ...) {
@@ -332,12 +349,13 @@ 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, ... = ...)
-  u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", ab_atc(ab), "&showdescription=no")
-  u[is.na(ab_atc(ab))] <- NA_character_
+  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(ab_atc(ab))]
+  NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
   if (length(NAs) > 0) {
     warning_("No ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
   }

R/atc_online.R

@@ -97,8 +97,8 @@ atc_online_property <- function(atc_code,
   
   check_dataset_integrity()
   
-  if (!all(atc_code %in% antibiotics)) {
-    atc_code <- as.character(ab_atc(atc_code))
+  if (!all(atc_code %in% unlist(antibiotics$atc))) {
+    atc_code <- as.character(ab_atc(atc_code, only_first = TRUE))
   }
   
   if (!has_internet()) {

R/bug_drug_combinations.R

@@ -218,7 +218,7 @@ format.bug_drug_combinations <- function(x,
       ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i])
       ab_txt[i] <- gsub("atc_group1", ab_atc_group1(ab[i], language = language), ab_txt[i])
       ab_txt[i] <- gsub("atc_group2", ab_atc_group2(ab[i], language = language), ab_txt[i])
-      ab_txt[i] <- gsub("atc", ab_atc(ab[i]), ab_txt[i])
+      ab_txt[i] <- gsub("atc", ab_atc(ab[i], only_first = TRUE), ab_txt[i])
       ab_txt[i] <- gsub("name", ab_name(ab[i], language = language), ab_txt[i])
       ab_txt[i]
     }

R/rsi.R

@@ -936,7 +936,7 @@ freq.rsi <- function(x, ...) {
   if (!is.na(ab)) {
     cleaner::freq.default(x = x, ...,
                           .add_header = list(
-                            Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", ab_atc(ab), ")"),
+                            Drug = paste0(ab_name(ab, language = NULL), " (", ab, ", ", paste(ab_atc(ab), collapse = "/"), ")"),
                             `Drug group` = ab_group(ab, language = NULL),
                             `%SI` = percentage(susceptibility(x, minimum = 0, as_percent = FALSE),
                                                digits = digits)))