(v1.7.1.9016) only_treatable ab selectors

R/ab_class_selectors.R

@@ -29,6 +29,7 @@
 #' @inheritSection lifecycle Stable Lifecycle
 #' @param ab_class an antimicrobial class, such as `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
 #' @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`)
 #' @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*.
 #' 
@@ -123,17 +124,20 @@
 #' }
 #' }
 ab_class <- function(ab_class, 
-                     only_rsi_columns = FALSE) {
+                     only_rsi_columns = FALSE,
+                     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)
-  ab_selector(NULL, only_rsi_columns = only_rsi_columns, ab_class = ab_class)
+  meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
+  ab_selector(NULL, only_rsi_columns = only_rsi_columns, ab_class = ab_class, only_treatable = only_treatable)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-aminoglycosides <- function(only_rsi_columns = FALSE) {
+aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_selector("aminoglycosides", only_rsi_columns = only_rsi_columns)
+  meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
+  ab_selector("aminoglycosides", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
 }
 
 #' @rdname antibiotic_class_selectors
@@ -145,16 +149,18 @@ aminopenicillins <- function(only_rsi_columns = FALSE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-betalactams <- function(only_rsi_columns = FALSE) {
+betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_selector("betalactams", only_rsi_columns = only_rsi_columns)
+  meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
+  ab_selector("betalactams", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
 }
 
 #' @rdname antibiotic_class_selectors
 #' @export
-carbapenems <- function(only_rsi_columns = FALSE) {
+carbapenems <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_selector("carbapenems", only_rsi_columns = only_rsi_columns)
+  meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
+  ab_selector("carbapenems", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
 }
 
 #' @rdname antibiotic_class_selectors
@@ -250,9 +256,10 @@ penicillins <- function(only_rsi_columns = FALSE) {
 
 #' @rdname antibiotic_class_selectors
 #' @export
-polymyxins <- function(only_rsi_columns = FALSE) {
+polymyxins <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
   meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
-  ab_selector("polymyxins", only_rsi_columns = only_rsi_columns)
+  meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
+  ab_selector("polymyxins", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
 }
 
 #' @rdname antibiotic_class_selectors
@@ -285,6 +292,7 @@ ureidopenicillins <- function(only_rsi_columns = FALSE) {
 
 ab_selector <- function(function_name,
                         only_rsi_columns,
+                        only_treatable,
                         ab_class = NULL) {
   # 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
@@ -292,6 +300,23 @@ ab_selector <- function(function_name,
   # to improve speed, get_column_abx() will only run once when e.g. in a select or group call
   ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
 
+  # untreatable drugs
+  untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate"), "ab", drop = TRUE]
+  if (only_treatable == TRUE & any(untreatable %in% names(ab_in_data))) {
+    if (message_not_thrown_before(paste0("ab_class.untreatable.", function_name), entire_session = TRUE)) {
+      warning_("Some agents in `", function_name, "()` were ignored since they cannot be used for treating patients: ",
+               vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
+                                  language = NULL,
+                                  tolower = TRUE),
+                          quotes = FALSE,
+                          sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
+               "This warning will be shown once per session.",
+               call = FALSE)
+      remember_thrown_message(paste0("ab_class.untreatable.", function_name), entire_session = TRUE)
+    }
+    ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
+  }
+  
   if (length(ab_in_data) == 0) {
     message_("No antimicrobial agents found in the data.")
     return(NULL)

R/bug_drug_combinations.R

@@ -81,7 +81,7 @@ bug_drug_combinations <- function(x,
   unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
   
   # select only groups and antibiotics
-  if (inherits(x.bak, "grouped_df")) {
+  if (is_null_or_grouped_tbl(x.bak)) {
     data_has_groups <- TRUE
     groups <- setdiff(names(attributes(x.bak)$groups), ".rows")
     x <- x[, c(groups, col_mo, colnames(x)[vapply(FUN.VALUE = logical(1), x, is.rsi)]), drop = FALSE]

R/mo.R

@@ -469,11 +469,11 @@ exec_as.mo <- function(x,
     x <- strip_whitespace(x, dyslexia_mode)
     # translate 'unknown' names back to English
     if (any(x %like% "unbekannt|onbekend|desconocid|sconosciut|iconnu|desconhecid", na.rm = TRUE)) {
-      trns <- subset(TRANSLATIONS, pattern %like% "unknown" | affect_mo_name == TRUE)
+      trns <- subset(TRANSLATIONS, pattern %like% "unknown")
       langs <- LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]
       for (l in langs) {
         for (i in seq_len(nrow(trns))) {
-          if (!is.na(trns[i, l, drop = TRUE]) && trns[i, l, drop = TRUE] %unlike% "\\\\1") {
+          if (!is.na(trns[i, l, drop = TRUE])) {
             x <- gsub(pattern = trns[i, l, drop = TRUE],
                       replacement = trns$pattern[i],
                       x = x,

R/rsi_calc.R

@@ -228,7 +228,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
   translate_ab <- get_translate_ab(translate_ab)
   
   # select only groups and antibiotics
-  if (inherits(data, "grouped_df")) {
+  if (is_null_or_grouped_tbl(data)) {
     data_has_groups <- TRUE
     groups <- setdiff(names(attributes(data)$groups), ".rows")
     data <- data[, c(groups, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)]), drop = FALSE]

R/zzz.R

@@ -38,7 +38,7 @@ if (utf8_supported && !is_latex) {
   pkg_env$info_icon <- "i"
 }
 
-.onLoad <- function(libname, pkgname) {
+.onLoad <- function(...) {
   # Support for tibble headers (type_sum) and tibble columns content (pillar_shaft)
   # without the need to depend on other packages. This was suggested by the 
   # developers of the vctrs package: 
@@ -86,7 +86,6 @@ if (utf8_supported && !is_latex) {
   assign(x = "INTRINSIC_R", value = create_intr_resistance(), envir = asNamespace("AMR"))
 }
 
-
 # Helper functions --------------------------------------------------------
 
 create_AB_lookup <- function() {