P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-11 07:41:59 +02:00
Code Releases Activity

(v1.6.0.9048) ab selectors overhaul

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-05-19 22:55:42 +02:00
parent 6920c0be41
commit 2413efd5c1
32 changed files with 1182 additions and 939 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
R/aa_helper_functions.R
View File

@ -336,6 +336,9 @@ word_wrap <- function(...,
collapse = "\n"))
}
# correct for operators (will add the space later on)
ops <- "([,./><\\]\\[])"
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE)
# we need to correct for already applied style, that adds text like "\033[31m\"
msg_stripped <- font_stripstyle(msg)
# where are the spaces now?
@ -352,6 +355,8 @@ word_wrap <- function(...,
# put it together
msg <- unlist(strsplit(msg, " "))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
# add space around operators again
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
@ -365,7 +370,7 @@ word_wrap <- function(...,
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
# remove trailing empty characters
msg <- gsub("(\n| )+$", "", msg)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
add_fn <- list(add_fn)
@ -709,7 +714,7 @@ get_current_data <- function(arg_name, call) {
if (!is.null(cur_data_all)) {
out <- tryCatch(cur_data_all(), error = function(e) NULL)
if (is.data.frame(out)) {
return(out)
return(structure(out, type = "dplyr_cur_data_all"))
}
}
@ -727,6 +732,7 @@ get_current_data <- function(arg_name, call) {
# try a (base R) method, by going over the complete system call stack with sys.frames()
not_set <- TRUE
source <- "base_R"
frms <- lapply(sys.frames(), function(el) {
if (not_set == TRUE && ".Generic" %in% names(el)) {
if (tryCatch(".data" %in% names(el) && is.data.frame(el$`.data`), error = function(e) FALSE)) {
@ -736,6 +742,7 @@ get_current_data <- function(arg_name, call) {
# an element `.data` will be in the system call stack when using dplyr::select()
# [but not when using dplyr::filter(), dplyr::mutate() or dplyr::summarise()]
not_set <<- FALSE
source <<- "dplyr_selector"
el$`.data`
} else if (tryCatch(any(c("x", "xx") %in% names(el)), error = function(e) FALSE)) {
# - - - -
@ -763,7 +770,7 @@ get_current_data <- function(arg_name, call) {
# lookup the matched frame and return its value: a data.frame
vars_df <- tryCatch(frms[[which(!vapply(FUN.VALUE = logical(1), frms, is.null))]], error = function(e) NULL)
if (is.data.frame(vars_df)) {
return(vars_df)
return(structure(vars_df, type = source))
}
# nothing worked, so:

254
R/ab_class_selectors.R
View File

@ -25,17 +25,19 @@
#' Antibiotic Class Selectors
#'
#' These functions help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations. \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
#' These functions help to filter and select columns with antibiotic test results that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations. \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
#' @inheritSection lifecycle Stable Lifecycle
#' @param ab_class an antimicrobial class, like `"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()]
#' @inheritParams filter_ab_class
#' @details \strong{\Sexpr{ifelse(as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2, paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
#'
#' All columns will be searched for known antibiotic names, abbreviations, brand names and codes (ATC, EARS-Net, WHO, etc.) in the [antibiotics] data set. This means that a selector like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#'
#' These functions can be used in data set calls for selecting columns and filtering rows, see *Examples*. They support base R, but work more convenient in dplyr functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()].
#'
#' 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.) in the [antibiotics] data set. This means that a selector like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#'
#' The group of betalactams consists of all carbapenems, cephalosporins and penicillins.
#' @rdname antibiotic_class_selectors
#' @seealso [filter_ab_class()] for the `filter()` equivalent.
#' @name antibiotic_class_selectors
#' @export
#' @inheritSection AMR Reference Data Publicly Available
@ -44,11 +46,31 @@
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' # Base R ------------------------------------------------------------------
#'
#' # select columns 'IPM' (imipenem) and 'MEM' (meropenem)
#' example_isolates[, carbapenems()]
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
#'
#' # select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB'
#' example_isolates[, c("mo", aminoglycosides())]
#'
#' # filter using any() or all()
#' example_isolates[any(carbapenems() == "R"), ]
#' subset(example_isolates, any(carbapenems() == "R"))
#'
#' # filter on any or all results in the carbapenem columns (i.e., IPM, MEM):
#' example_isolates[any(carbapenems()), ]
#' example_isolates[all(carbapenems()), ]
#'
#' # filter with multiple antibiotic selectors using c()
#' example_isolates[all(c(carbapenems(), aminoglycosides()) == "R"), ]
#'
#' # filter + select in one go: get penicillins in carbapenems-resistant strains
#' example_isolates[any(carbapenems() == "R"), penicillins()]
#'
#'
#' # dplyr -------------------------------------------------------------------
#'
#' if (require("dplyr")) {
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
@ -59,6 +81,20 @@
#' example_isolates %>%
#' select(mo, aminoglycosides())
#'
#' # any() and all() work in dplyr's filter() too:
#' example_isolates %>%
#' filter(any(aminoglycosides() == "R"),
#' all(cephalosporins_2nd() == "R"))
#'
#' # also works with c():
#' example_isolates %>%
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
#'
#' # not setting any/all will automatically apply all():
#' example_isolates %>%
#' filter(aminoglycosides() == "R")
#' #> i Assuming a filter on all 4 aminoglycosides.
#'
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
#' example_isolates %>%
#' select(mo, ab_class("mycobact"))
@ -77,10 +113,11 @@
#' select(penicillins()) # only the 'J01CA01' column will be selected
#'
#'
#' # with dplyr 1.0.0 and higher (that adds 'across()'), this is equal:
#' # with dplyr 1.0.0 and higher (that adds 'across()'), this is all equal:
#' # (though the row names on the first are more correct)
#' example_isolates %>% filter_carbapenems("R", "all")
#' example_isolates %>% filter(across(carbapenems(), ~. == "R"))
#' example_isolates[carbapenems() == "R", ]
#' example_isolates %>% filter(carbapenems() == "R")
#' example_isolates %>% filter(across(carbapenems(), ~.x == "R"))
#' }
ab_class <- function(ab_class,
only_rsi_columns = FALSE) {
@ -229,11 +266,204 @@ ab_selector <- function(ab_class,
need_name <- tolower(gsub("[^a-zA-Z]", "", agents)) != tolower(gsub("[^a-zA-Z]", "", agents_names))
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
" (", agents_names[need_name], ")")
message_("Applying `", function_name, "()`: selecting ",
ifelse(length(agents) == 1, "column ", "columns "),
message_("For `", function_name, "(", ifelse(function_name == "ab_class", paste0("\"", ab_class, "\""), ""), ")` using ",
ifelse(length(agents) == 1, "column: ", "columns: "),
vector_and(agents_formatted, quotes = FALSE))
}
remember_thrown_message(function_name)
}
unname(agents)
if (!is.null(attributes(vars_df)$type) &&
attributes(vars_df)$type %in% c("dplyr_cur_data_all", "base_R") &&
!any(as.character(sys.calls()) %like% paste0("(across|if_any|if_all)\\((c\\()?[a-z(), ]*", function_name))) {
structure(unname(agents),
class = c("ab_selector", "character"))
} else {
# don't return with "ab_selector" class if method is a dplyr selector,
# dplyr::select() will complain:
# > Subscript has the wrong type `ab_selector`.
# > It must be numeric or character.
unname(agents)
}
}
#' @method c ab_selector
#' @export
#' @noRd
c.ab_selector <- function(...) {
structure(unlist(lapply(list(...), as.character)),
class = c("ab_selector", "character"))
}
all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
cols_ab <- c(...)
result <- cols_ab[toupper(cols_ab) %in% c("R", "S", "I")]
if (length(result) == 0) {
result <- c("R", "S", "I")
}
cols_ab <- cols_ab[!cols_ab %in% result]
df <- get_current_data(arg_name = NA, call = -3)
if (type == "all") {
scope_fn <- all
} else {
scope_fn <- any
}
x_transposed <- as.list(as.data.frame(t(df[, cols_ab, drop = FALSE]), stringsAsFactors = FALSE))
vapply(FUN.VALUE = logical(1),
X = x_transposed,
FUN = function(y) scope_fn(y %in% result, na.rm = na.rm),
USE.NAMES = FALSE)
}
#' @method all ab_selector
#' @export
#' @noRd
all.ab_selector <- function(..., na.rm = FALSE) {
# this is all() for
all_any_ab_selector("all", ..., na.rm = na.rm)
}
#' @method any ab_selector
#' @export
#' @noRd
any.ab_selector <- function(..., na.rm = FALSE) {
all_any_ab_selector("any", ..., na.rm = na.rm)
}
#' @method all ab_selector_any_all
#' @export
#' @noRd
all.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is all() on a logical vector from `==.ab_selector` or `!=.ab_selector`
# e.g., example_isolates %>% filter(all(carbapenems() == "R"))
# so just return the vector as is, only correcting for na.rm
out <- unclass(c(...))
if (na.rm == TRUE) {
out <- out[!is.na(out)]
}
out
}
#' @method any ab_selector_any_all
#' @export
#' @noRd
any.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is any() on a logical vector from `==.ab_selector` or `!=.ab_selector`
# e.g., example_isolates %>% filter(any(carbapenems() == "R"))
# so just return the vector as is, only correcting for na.rm
out <- unclass(c(...))
if (na.rm == TRUE) {
out <- out[!is.na(out)]
}
out
}
#' @method == ab_selector
#' @export
#' @noRd
`==.ab_selector` <- function(e1, e2) {
calls <- as.character(match.call())
fn_name <- calls[2]
# keep only the ... in c(...)
fn_name <- gsub("^(c\\()(.*)(\\))$", "\\2", fn_name)
if (is_any(fn_name)) {
type <- "any"
} else if (is_all(fn_name)) {
type <- "all"
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
}
}
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
}
#' @method != ab_selector
#' @export
#' @noRd
`!=.ab_selector` <- function(e1, e2) {
calls <- as.character(match.call())
fn_name <- calls[2]
# keep only the ... in c(...)
fn_name <- gsub("^(c\\()(.*)(\\))$", "\\2", fn_name)
if (is_any(fn_name)) {
type <- "any"
} else if (is_all(fn_name)) {
type <- "all"
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
}
}
# this is `!=`, so turn around the values
rsi <- c("R", "S", "I")
e2 <- rsi[rsi != e2]
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
}
is_any <- function(el1) {
syscall <- paste0(trimws(deparse(sys.calls()[[1]])), collapse = " ")
el1 <- gsub("(.*),.*", "\\1", el1)
syscall %like% paste0("[^_a-zA-Z0-9]any\\(", "(c\\()?", el1)
}
is_all <- function(el1) {
syscall <- paste0(trimws(deparse(sys.calls()[[1]])), collapse = " ")
el1 <- gsub("(.*),.*", "\\1", el1)
syscall %like% paste0("[^_a-zA-Z0-9]all\\(", "(c\\()?", el1)
}
find_ab_group <- function(ab_class) {
ab_class[ab_class == "carbapenem|cephalosporin|penicillin"] <- "betalactam"
ab_class <- gsub("[^a-zA-Z0-9]", ".*", ab_class)
ifelse(ab_class %in% c("aminoglycoside",
"betalactam",
"carbapenem",
"cephalosporin",
"fluoroquinolone",
"glycopeptide",
"macrolide",
"oxazolidinone",
"tetracycline"),
paste0(ab_class, "s"),
antibiotics %pm>%
subset(group %like% ab_class |
atc_group1 %like% ab_class |
atc_group2 %like% ab_class) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
sort() %pm>%
paste(collapse = "/")
)
}
find_ab_names <- function(ab_group, n = 3) {
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
# try popular first, they have DDDs
drugs <- antibiotics[which((!is.na(antibiotics$iv_ddd) | !is.na(antibiotics$oral_ddd)) &
antibiotics$name %unlike% " " &
antibiotics$group %like% ab_group &
antibiotics$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- antibiotics[which((antibiotics$group %like% ab_group |
antibiotics$atc_group1 %like% ab_group |
antibiotics$atc_group2 %like% ab_group) &
antibiotics$ab %unlike% "[0-9]$"), ]$name
}
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL),
quotes = FALSE)
}

364
R/deprecated.R
View File

@ -25,7 +25,8 @@
#' Deprecated Functions
#'
#' These functions are so-called '[Deprecated]'. They will be removed in a future release. Using the functions will give a warning with the name of the function it has been replaced by (if there is one).
#' These functions are so-called '[Deprecated]'. **They will be removed in a future release.** Using the functions will give a warning with the name of the function it has been replaced by (if there is one).
#' @details All antibiotic class selectors (such as [carbapenems()], [aminoglycosides()]) can now be used for filtering as well, making all their accompanying `filter_*()` functions redundant (such as [filter_carbapenems()], [filter_aminoglycosides()]).
#' @inheritSection lifecycle Retired Lifecycle
#' @inheritSection AMR Read more on Our Website!
#' @keywords internal
@ -138,3 +139,364 @@ key_antibiotics_equal <- function(y,
points_threshold = points_threshold,
info = info)
}
#' @name AMR-deprecated
#' @export
filter_ab_class <- function(x,
ab_class,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
.call_depth <- list(...)$`.call_depth`
if (is.null(.call_depth)) {
.call_depth <- 0
}
.x_name <- list(...)$`.x_name`
if (is.null(.x_name)) {
.x_name <- deparse(substitute(x))
}
.fn <- list(...)$`.fn`
if (is.null(.fn)) {
.fn <- "filter_ab_class"
}
.fn_old <- .fn
# new way: using the ab selectors
.fn <- gsub("filter_", "", .fn, fixed = TRUE)
.fn <- gsub("^([1-5][a-z]+)_cephalosporins", "cephalosporins_\\1", .fn)
if (missing(x) || is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2 - .call_depth)
.x_name <- "your_data"
}
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
if (!is.null(result)) {
# make result = "SI" works too:
result <- toupper(unlist(strsplit(result, "")))
}
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), is_in = c("S", "I", "R"), allow_NULL = TRUE, .call_depth = .call_depth)
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = .call_depth)
if (is.null(result)) {
result <- c("S", "I", "R")
}
# get e.g. carbapenems() from filter_carbapenems()
fn <- get(.fn, envir = asNamespace("AMR"))
if (scope == "any") {
scope_fn <- any
} else {
scope_fn <- all
}
# be nice here, be VERY extensive about how the AB selectors have taken over this function
deprecated_fn <- paste0(.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ")",
ifelse(length(result) > 1,
paste0(", c(", paste0("\"", result, "\"", collapse = ", "), ")"),
ifelse(is.null(result),
"",
paste0(" == \"", result, "\""))))
if (.x_name == ".") {
.x_name <- "your_data"
}
warning_(paste0("`", .fn_old, "()` is deprecated. Use the antibiotic selector `", .fn, "()` instead.\n",
"In dplyr:\n",
" - ", .x_name, " %>% filter(", scope, "(", deprecated_fn, "))\n",
ifelse(length(result) > 1,
paste0(" - ", .x_name, " %>% filter(", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"))\n"),
""),
"In base R:\n",
" - ", .x_name, "[", scope, "(", deprecated_fn, "), ]\n",
ifelse(length(result) > 1,
paste0(" - ", .x_name, "[", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"), ]\n"),
""),
" - subset(", .x_name, ", ", scope, "(", deprecated_fn, "))",
ifelse(length(result) > 1,
paste0("\n - subset(", .x_name, ", ", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"))"),
"")),
call = FALSE)
if (.fn == "ab_class") {
subset(x, scope_fn(fn(ab_class = ab_class), result))
} else {
subset(x, scope_fn(fn(), result))
}
}
#' @name AMR-deprecated
#' @export
filter_aminoglycosides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_aminoglycosides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_betalactams <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem|cephalosporin|penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_betalactams",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_carbapenems <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_carbapenems",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_1st_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_1st_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_2nd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_2nd_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_3rd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_3rd_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_4th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_4th_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_5th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_5th_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_fluoroquinolones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_fluoroquinolones",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_glycopeptides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "glycopeptide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_glycopeptides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_macrolides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "macrolide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_macrolides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_oxazolidinones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "oxazolidinone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_oxazolidinones",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_penicillins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_penicillins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_tetracyclines <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "tetracycline",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_tetracyclines",
.x_name = deparse(substitute(x)),
...)
}

510
R/filter_ab_class.R
View File

@ -1,510 +0,0 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Data Analysis for R #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2021 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# 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/ #
# ==================================================================== #
#' Filter Isolates on Result in Antimicrobial Class
#'
#' Filter isolates on results in specific antimicrobial classes. This makes it easy to filter on isolates that were tested for e.g. any aminoglycoside, or to filter on carbapenem-resistant isolates without the need to specify the drugs.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a data set
#' @param ab_class an antimicrobial class, like `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
#' @param result an antibiotic result: S, I or R (or a combination of more of them)
#' @param scope the scope to check which variables to check, can be `"any"` (default) or `"all"`
#' @param only_rsi_columns a [logical] to indicate whether only columns must be included that were transformed to class `<rsi>` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param ... arguments passed on to [filter_ab_class()]
#' @details All columns of `x` will be searched for known antibiotic names, abbreviations, brand names and codes (ATC, EARS-Net, WHO, etc.). This means that a filter function like e.g. [filter_aminoglycosides()] will include column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#'
#' The group of betalactams consists of all carbapenems, cephalosporins and penicillins.
#' @rdname filter_ab_class
#' @seealso [antibiotic_class_selectors()] for the `select()` equivalent.
#' @export
#' @examples
#' x <- filter_carbapenems(example_isolates)
#' \donttest{
#' # base R filter options (requires R >= 3.2)
#' example_isolates[filter_carbapenems(), ]
#' example_isolates[which(filter_carbapenems() & mo_is_gram_negative()), ]
#'
#' if (require("dplyr")) {
#'
#' # filter on isolates that have any result for any aminoglycoside
#' example_isolates %>% filter_aminoglycosides()
#' example_isolates %>% filter_ab_class("aminoglycoside")
#'
#' # this is essentially the same as (but without determination of column names):
#' example_isolates %>%
#' filter_at(.vars = vars(c("GEN", "TOB", "AMK", "KAN")),
#' .vars_predicate = any_vars(. %in% c("S", "I", "R")))
#'
#'
#' # filter on isolates that show resistance to ANY aminoglycoside
#' example_isolates %>% filter_aminoglycosides("R", "any")
#'
#' # filter on isolates that show resistance to ALL aminoglycosides
#' example_isolates %>% filter_aminoglycosides("R", "all")
#'
#' # filter on isolates that show resistance to
#' # any aminoglycoside and any fluoroquinolone
#' example_isolates %>%
#' filter_aminoglycosides("R") %>%
#' filter_fluoroquinolones("R")
#'
#' # filter on isolates that show resistance to
#' # all aminoglycosides and all fluoroquinolones
#' example_isolates %>%
#' filter_aminoglycosides("R", "all") %>%
#' filter_fluoroquinolones("R", "all")
#'
#' # with dplyr 1.0.0 and higher (that adds 'across()'), this is all equal:
#' # (though the row names on the first are more correct)
#' example_isolates %>% filter_carbapenems("R", "all")
#' example_isolates %>% filter(across(carbapenems(), ~. == "R"))
#' example_isolates %>% filter(across(carbapenems(), function(x) x == "R"))
#' example_isolates %>% filter(filter_carbapenems("R", "all"))
#' }
#' }
filter_ab_class <- function(x,
ab_class,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
.call_depth <- list(...)$`.call_depth`
if (is.null(.call_depth)) {
.call_depth <- 0
}
.fn <- list(...)$`.fn`
if (is.null(.fn)) {
.fn <- "filter_ab_class"
}
return_only_row_indices <- FALSE
if (missing(x) || is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
x <- get_current_data(arg_name = "x", call = -2 - .call_depth)
return_only_row_indices <- TRUE
}
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
if (!is.null(result)) {
result <- toupper(result)
}
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), is_in = c("S", "I", "R"), allow_NULL = TRUE, .call_depth = .call_depth)
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = .call_depth)
check_dataset_integrity()
# save to return later
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (is.null(result)) {
result <- c("S", "I", "R")
}
# make result = "SI" works too:
result <- unlist(strsplit(result, ""))
# get all columns in data with names that resemble antibiotics
ab_in_data <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
# improve speed here so it will only run once when e.g. in one select call
if (!identical(pkg_env$filter_ab_selector, unique_call_id())) {
ab_in_data <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
pkg_env$filter_ab_selector <- unique_call_id()
pkg_env$filter_ab_selector_cols <- ab_in_data
} else {
ab_in_data <- pkg_env$filter_ab_selector_cols
}
if (length(ab_in_data) == 0) {
message_("No columns with antibiotic test results found (see ?as.rsi), data left unchanged.")
return(x.bak)
}
# get reference data
ab_class.bak <- ab_class
ab_class <- gsub("[^a-zA-Z|0-9]+", ".*", ab_class)
ab_class <- gsub("(ph|f)", "(ph|f)", ab_class)
ab_class <- gsub("(t|th)", "(t|th)", ab_class)
ab_reference <- subset(antibiotics,
group %like% ab_class |
atc_group1 %like% ab_class |
atc_group2 %like% ab_class)
if (nrow(ab_reference) == 0) {
message_("Unknown antimicrobial class '", ab_class.bak, "', data left unchanged.")
return(x.bak)
}
ab_group <- find_ab_group(ab_class.bak)
# get the columns with a group names in the chosen ab class
agents <- ab_in_data[names(ab_in_data) %in% ab_reference$ab]
if (length(agents) == 0) {
message_("No antimicrobial agents of class '", ab_group,
"' found (such as ", find_ab_names(ab_class, 2),
")",
ifelse(only_rsi_columns == TRUE, " with class <rsi>,", ","),
" data left unchanged.")
return(x.bak)
}
if (scope == "any") {
scope_txt <- " or "
scope_fn <- any
} else {
scope_txt <- " and "
scope_fn <- all
}
if (length(agents) > 1) {
operator <- " are"
scope <- paste("values in", scope, "of columns ")
} else {
operator <- " is"
scope <- "value in column "
}
if (length(result) > 1) {
operator <- paste(operator, "either")
}
# sort columns on official name
agents <- agents[order(ab_name(names(agents), language = NULL))]
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- tolower(gsub("[^a-zA-Z]", "", agents)) != tolower(gsub("[^a-zA-Z]", "", agents_names))
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
" (", agents_names[need_name], ")")
message_("Applying `", .fn, "()`: ", scope,
vector_or(agents_formatted, quotes = FALSE, last_sep = scope_txt),
operator, " ", vector_or(result, quotes = TRUE))
x_transposed <- as.list(as.data.frame(t(x[, agents, drop = FALSE]), stringsAsFactors = FALSE))
filtered <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) scope_fn(y %in% result, na.rm = TRUE))
if (return_only_row_indices == TRUE) {
filtered
} else {
# this returns the original data with the filtering, also preserving attributes (such as dplyr groups)
x.bak[which(filtered), , drop = FALSE]
}
}
#' @rdname filter_ab_class
#' @export
filter_aminoglycosides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_aminoglycosides",
...)
}
#' @rdname filter_ab_class
#' @export
filter_betalactams <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem|cephalosporin|penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_betalactams",
...)
}
#' @rdname filter_ab_class
#' @export
filter_carbapenems <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_carbapenems",
...)
}
#' @rdname filter_ab_class
#' @export
filter_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_1st_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_1st_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_2nd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_2nd_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_3rd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_3rd_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_4th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_4th_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_5th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_5th_cephalosporins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_fluoroquinolones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_fluoroquinolones",
...)
}
#' @rdname filter_ab_class
#' @export
filter_glycopeptides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "glycopeptide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_glycopeptides",
...)
}
#' @rdname filter_ab_class
#' @export
filter_macrolides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "macrolide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_macrolides",
...)
}
#' @rdname filter_ab_class
#' @export
filter_oxazolidinones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "oxazolidinone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_oxazolidinones",
...)
}
#' @rdname filter_ab_class
#' @export
filter_penicillins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_penicillins",
...)
}
#' @rdname filter_ab_class
#' @export
filter_tetracyclines <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "tetracycline",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_tetracyclines",
...)
}
find_ab_group <- function(ab_class) {
ab_class[ab_class == "carbapenem|cephalosporin|penicillin"] <- "betalactam"
ab_class <- gsub("[^a-zA-Z0-9]", ".*", ab_class)
ifelse(ab_class %in% c("aminoglycoside",
"betalactam",
"carbapenem",
"cephalosporin",
"fluoroquinolone",
"glycopeptide",
"macrolide",
"oxazolidinone",
"tetracycline"),
paste0(ab_class, "s"),
antibiotics %pm>%
subset(group %like% ab_class |
atc_group1 %like% ab_class |
atc_group2 %like% ab_class) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
sort() %pm>%
paste(collapse = "/")
)
}
find_ab_names <- function(ab_group, n = 3) {
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
# try popular first, they have DDDs
drugs <- antibiotics[which((!is.na(antibiotics$iv_ddd) | !is.na(antibiotics$oral_ddd)) &
antibiotics$name %unlike% " " &
antibiotics$group %like% ab_group &
antibiotics$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- antibiotics[which((antibiotics$group %like% ab_group |
antibiotics$atc_group1 %like% ab_group |
antibiotics$atc_group2 %like% ab_group) &
antibiotics$ab %unlike% "[0-9]$"), ]$name
}
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL),
quotes = FALSE)
}