(v1.7.1.9063) not_intrinsic_resistant

R/aa_helper_functions.R

@@ -194,7 +194,7 @@ check_dataset_integrity <- function() {
   data_in_globalenv <- ls(envir = globalenv())
   overwritten <- data_in_pkg[data_in_pkg %in% data_in_globalenv]
   # exception for example_isolates
-  overwritten <- overwritten[overwritten != "example_isolates"]
+  overwritten <- overwritten[overwritten %unlike% "example_isolates"]
   if (length(overwritten) > 0) {
     if (length(overwritten) > 1) {
       plural <- c("s are", "", "s")

R/ab_selectors.R

@@ -38,11 +38,6 @@
 #' All columns in the data in which these functions are called will be searched for known antibiotic names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc. 
 #' 
 #' The [ab_class()] function can be used to filter/select on a manually defined antibiotic class. It searches for results in the [antibiotics] data set within the columns `group`, `atc_group1` and `atc_group2`.
-#' 
-#' The [ab_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
-#' 
-#' The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antibiotic columns will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
-#' 
 #' @section Full list of supported (antibiotic) classes:
 #' 
 #' `r paste0(" * ", na.omit(sapply(DEFINED_AB_GROUPS, function(ab) ifelse(tolower(gsub("^AB_", "", ab)) %in% ls(envir = asNamespace("AMR")), paste0("[", tolower(gsub("^AB_", "", ab)), "()] can select: \\cr ", vector_and(paste0(ab_name(eval(parse(text = ab), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), " (", eval(parse(text = ab), envir = asNamespace("AMR")), ")"), quotes = FALSE, sort = TRUE)), character(0)), USE.NAMES = FALSE)), "\n", collapse = "")`
@@ -105,6 +100,12 @@
 #'   # You can combine selectors with '&' to be more specific:
 #'   example_isolates %>%
 #'     select(penicillins() & administrable_per_os())
+#'   
+#'   # get AMR for only drugs that matter - no intrinsic resistance:
+#'   example_isolates %>%
+#'     filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>% 
+#'     group_by(hospital_id) %>% 
+#'     summarise(across(not_intrinsic_resistant(), resistance))
 #'     
 #'   # get susceptibility for antibiotics whose name contains "trim":
 #'   example_isolates %>%
@@ -167,6 +168,7 @@ ab_class <- function(ab_class,
 }
 
 #' @rdname antibiotic_class_selectors
+#' @details The [ab_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
 #' @export
 ab_selector <- function(filter, 
                         only_rsi_columns = FALSE,
@@ -193,90 +195,6 @@ ab_selector <- function(filter,
             class = c("ab_selector", "character"))
 }
 
-#' @rdname antibiotic_class_selectors
-#' @export
-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
-  vars_df <- get_current_data(arg_name = NA, call = -2)
-  # 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)
-  agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
-  agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
-  agents <- ab_in_data[ab_in_data %in% agents]
-  message_agent_names(function_name = "administrable_per_os", 
-                      agents = agents,
-                      ab_group = "administrable_per_os",
-                      examples = paste0(" (such as ", 
-                                        vector_or(ab_name(sample(agents_all,
-                                                                 size = min(5, length(agents_all)),
-                                                                 replace = FALSE),
-                                                          tolower = TRUE,
-                                                          language = NULL),
-                                                  quotes = FALSE), 
-                                        ")"))
-  structure(unname(agents),
-            class = c("ab_selector", "character"))
-}
-
-#' @rdname antibiotic_class_selectors
-#' @export
-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
-  vars_df <- get_current_data(arg_name = NA, call = -2)
-  # 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)
-  agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
-  agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
-  agents <- ab_in_data[ab_in_data %in% agents]
-  message_agent_names(function_name = "administrable_iv", 
-                      agents = agents,
-                      ab_group = "administrable_iv",
-                      examples = "")
-  structure(unname(agents),
-            class = c("ab_selector", "character"))
-}
-
-# nolint start
-# #' @rdname antibiotic_class_selectors
-# #' @export
-# 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)
-# 
-#   x <- as.mo(mo, ...)
-#   wont_work <- intrinsic_resistant[which(intrinsic_resistant$microorganism == mo_name(x, language = NULL)),
-#                                    "antibiotic",
-#                                    drop = TRUE]
-# 
-#   # 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
-#   vars_df <- get_current_data(arg_name = NA, call = -2)
-#   # 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)
-# 
-#   agents <- ab_in_data[!names(ab_in_data) %in% as.character(as.ab(wont_work))]
-# 
-#   # show used version number once per session (pkg_env will reload every session)
-#   if (message_not_thrown_before("intrinsic_resistant_version.ab", entire_session = TRUE)) {
-#     message_("Determining intrinsic resistance based on ",
-#              format_eucast_version_nr(3.2, markdown = FALSE), ". ",
-#              font_red("This note will be shown once per session."))
-#   }
-# 
-#   message_agent_names(function_name = "not_intrinsic_resistant", 
-#                       agents = ab_in_data,
-#                       ab_group = NULL,
-#                       examples = "",
-#                       call = mo_name(x, language = NULL))
-# 
-#   agents
-# }
-# nolint end
-
 #' @rdname antibiotic_class_selectors
 #' @export
 aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
@@ -456,6 +374,94 @@ ureidopenicillins <- function(only_rsi_columns = FALSE, ...) {
   ab_select_exec("ureidopenicillins", only_rsi_columns = only_rsi_columns)
 }
 
+#' @rdname antibiotic_class_selectors
+#' @details The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antibiotic columns will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
+#' @export
+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
+  vars_df <- get_current_data(arg_name = NA, call = -2)
+  # 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)
+  agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
+  agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
+  agents <- ab_in_data[ab_in_data %in% agents]
+  message_agent_names(function_name = "administrable_per_os", 
+                      agents = agents,
+                      ab_group = "administrable_per_os",
+                      examples = paste0(" (such as ", 
+                                        vector_or(ab_name(sample(agents_all,
+                                                                 size = min(5, length(agents_all)),
+                                                                 replace = FALSE),
+                                                          tolower = TRUE,
+                                                          language = NULL),
+                                                  quotes = FALSE), 
+                                        ")"))
+  structure(unname(agents),
+            class = c("ab_selector", "character"))
+}
+
+#' @rdname antibiotic_class_selectors
+#' @export
+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
+  vars_df <- get_current_data(arg_name = NA, call = -2)
+  # 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)
+  agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
+  agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
+  agents <- ab_in_data[ab_in_data %in% agents]
+  message_agent_names(function_name = "administrable_iv", 
+                      agents = agents,
+                      ab_group = "administrable_iv",
+                      examples = "")
+  structure(unname(agents),
+            class = c("ab_selector", "character"))
+}
+
+#' @rdname antibiotic_class_selectors
+#' @inheritParams eucast_rules
+#' @details The [not_intrinsic_resistant()] function can be used to only select antibiotic columns that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of *E. coli* and *K. pneumoniae* and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies `r format_eucast_version_nr(names(EUCAST_VERSION_EXPERT_RULES[length(EUCAST_VERSION_EXPERT_RULES)]))` to determine intrinsic resistance, using the [eucast_rules()] function internally. Because of this determination, this function is quite slow in terms of performance.
+#' @export
+not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, version_expertrules = 3.3, ...) {
+  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
+  vars_df <- get_current_data(arg_name = NA, call = -2)
+  # 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)
+  # intrinsic vars
+  vars_df_R <- tryCatch(sapply(eucast_rules(vars_df,
+                                            col_mo = col_mo,
+                                            version_expertrules = version_expertrules,
+                                            rules = "expert",
+                                            info = FALSE),
+                               function(col) tryCatch(!any(is.na(col)) && all(col == "R"),
+                                                      error = function(e) FALSE)),
+                        error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE))
+  
+  agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
+  if (length(agents) > 0 &&
+      message_not_thrown_before(paste0("not_intrinsic_resistant.", paste(sort(agents), collapse = "|")))) {
+    agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
+    agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
+    need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
+    agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
+    message_("For `not_intrinsic_resistant()` removing ",
+             ifelse(length(agents) == 1, "column ", "columns "),
+             vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
+  }
+  
+  vars_df_R <- names(vars_df_R)[which(!vars_df_R)]
+  # find columns that are abx, but also intrinsic R
+  out <- unname(intersect(ab_in_data, vars_df_R))
+  structure(out,
+            class = c("ab_selector", "character"))
+}
+
 ab_select_exec <- function(function_name,
                            only_rsi_columns = FALSE,
                            only_treatable = FALSE,
@@ -465,7 +471,6 @@ ab_select_exec <- function(function_name,
   vars_df <- get_current_data(arg_name = NA, call = -3)
   # 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))) {

R/eucast_rules.R

@@ -59,7 +59,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
 #' @param verbose a [logical] to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. Using Verbose mode takes a lot more time.
 #' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Can be either `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
 #' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either `r vector_or(names(EUCAST_VERSION_EXPERT_RULES), reverse = TRUE)`.
-#' @param ampc_cephalosporin_resistance a [character] value that should be applied to cefotaxime, ceftriaxone and ceftazidime for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2`; '*EUCAST Expert Rules v3.2 on Enterobacterales*' states that results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these three agents. A value of `NA` (the default) for this argument will remove results for these three agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` or `FALSE` to not alter results for these three agents of AmpC de-repressed cephalosporin-resistant mutants. Using `TRUE` is equal to using `"R"`. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: `r vector_and(gsub("[^a-zA-Z ]+", "", unlist(strsplit(EUCAST_RULES_DF[which(EUCAST_RULES_DF$reference.version == 3.2 & EUCAST_RULES_DF$reference.rule %like% "ampc"), "this_value"][1], "|", fixed = TRUE))), quotes = "*")`.
+#' @param ampc_cephalosporin_resistance a [character] value that should be applied to cefotaxime, ceftriaxone and ceftazidime for AmpC de-repressed cephalosporin-resistant mutants, defaults to `NA`. Currently only works when `version_expertrules` is `3.2` and higher; these version of '*EUCAST Expert Rules on Enterobacterales*' state that results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these three agents. A value of `NA` (the default) for this argument will remove results for these three agents, while e.g. a value of `"R"` will make the results for these agents resistant. Use `NULL` or `FALSE` to not alter results for these three agents of AmpC de-repressed cephalosporin-resistant mutants. Using `TRUE` is equal to using `"R"`. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: `r vector_and(gsub("[^a-zA-Z ]+", "", unlist(strsplit(EUCAST_RULES_DF[which(EUCAST_RULES_DF$reference.version %in% c(3.2, 3.3) & EUCAST_RULES_DF$reference.rule %like% "ampc"), "this_value"][1], "|", fixed = TRUE))), quotes = "*")`.
 #' @param ... column name of an antibiotic, see section *Antibiotics* below
 #' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
 #' @param administration route of administration, either `r vector_or(dosage$administration)`

R/guess_ab_col.R

@@ -238,9 +238,10 @@ get_column_abx <- function(x,
   if (sort == TRUE) {
     out <- out[order(names(out), out)]
   }
-  duplicates <- c(out[duplicated(out)], out[duplicated(names(out))]) 
-  duplicates <- duplicates[unique(names(duplicates))]
-  out <- c(out[!names(out) %in% names(duplicates)], duplicates)
+  # only keep the first hits, no duplicates
+  duplicates <- c(out[duplicated(names(out))], out[duplicated(unname(out))])
+  out <- out[!duplicated(names(out))]
+  out <- out[!duplicated(unname(out))]
   if (sort == TRUE) {
     out <- out[order(names(out), out)]
   }

R/mo_matching_score.R

@@ -27,7 +27,7 @@
 #' 
 #' This algorithm is used by [as.mo()] and all the [`mo_*`][mo_property()] functions to determine the most probable match of taxonomic records based on user input. 
 #' @inheritSection lifecycle Stable Lifecycle
-#' @author Matthijs S. Berends
+#' @author Dr. Matthijs Berends
 #' @param x Any user input value(s)
 #' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
 #' @section Matching Score for Microorganisms:

R/mo_property.R

@@ -96,6 +96,7 @@
 #' mo_ref("E. coli")             # "Castellani et al., 1919"
 #' mo_authors("E. coli")         # "Castellani et al."
 #' mo_year("E. coli")            # 1919
+#' mo_lpsn("E. coli")            # 776057 (LPSN record ID)
 #'
 #' # abbreviations known in the field -----------------------------------------
 #' mo_genus("MRSA")              # "Staphylococcus"
@@ -538,6 +539,19 @@ mo_year <- function(x, language = get_locale(), ...) {
   suppressWarnings(as.integer(x))
 }
 
+#' @rdname mo_property
+#' @export
+mo_lpsn <- function(x, language = get_locale(), ...) {
+  if (missing(x)) {
+    # this tries to find the data and an <mo> column
+    x <- find_mo_col(fn = "mo_rank")
+  }
+  meet_criteria(x, allow_NA = TRUE)
+  meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
+  
+  mo_validate(x = x, property = "species_id", language = language, ...)
+}
+
 #' @rdname mo_property
 #' @export
 mo_rank <- function(x, language = get_locale(), ...) {
@@ -724,6 +738,8 @@ mo_validate <- function(x, property, language, ...) {
   
   if (property == "mo") {
     return(set_clean_class(x, new_class = c("mo", "character")))
+  } else if (property == "species_id") {
+    return(as.double(x))
   } else if (property == "snomed") {
     return(as.double(eval(parse(text = x))))
   } else {