2019-03-05 22:47:42 +01:00
# ==================================================================== #
# TITLE #
2020-10-08 11:16:03 +02:00
# Antimicrobial Resistance (AMR) Analysis for R #
2019-03-05 22:47:42 +01:00
# #
# SOURCE #
2020-07-08 14:48:06 +02:00
# https://github.com/msberends/AMR #
2019-03-05 22:47:42 +01:00
# #
# LICENCE #
2020-12-27 00:30:28 +01:00
# (c) 2018-2021 Berends MS, Luz CF et al. #
2020-10-08 11:16:03 +02:00
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
2019-03-05 22:47:42 +01:00
# #
# 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. #
2020-01-05 17:22:09 +01:00
# 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. #
2020-10-08 11:16:03 +02:00
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
2019-03-05 22:47:42 +01:00
# ==================================================================== #
2020-05-16 13:05:47 +02:00
#' Filter isolates on result in antimicrobial class
2019-03-05 22:47:42 +01:00
#'
2020-06-03 11:48:00 +02:00
#' 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.
2020-01-05 17:22:09 +01:00
#' @inheritSection lifecycle Stable lifecycle
2019-08-12 14:48:09 +02:00
#' @param x a data set
2020-06-17 01:39:30 +02:00
#' @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.
2019-03-05 22:47:42 +01:00
#' @param result an antibiotic result: S, I or R (or a combination of more of them)
2019-11-28 22:32:17 +01:00
#' @param scope the scope to check which variables to check, can be `"any"` (default) or `"all"`
2020-07-12 11:43:31 +02:00
#' @param ... previously used when this package still depended on the `dplyr` package, now ignored
2020-06-17 01:39:30 +02:00
#' @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.
2019-03-05 22:47:42 +01:00
#' @rdname filter_ab_class
2020-06-17 01:39:30 +02:00
#' @seealso [antibiotic_class_selectors()] for the `select()` equivalent.
2019-03-05 22:47:42 +01:00
#' @export
#' @examples
2020-09-29 23:35:46 +02:00
#' filter_aminoglycosides(example_isolates)
#'
#' \donttest{
#' if (require("dplyr")) {
2019-03-05 22:47:42 +01:00
#'
2020-09-29 23:35:46 +02:00
#' # 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")))
2019-03-05 22:47:42 +01:00
#'
2019-03-26 14:24:03 +01:00
#'
2020-09-29 23:35:46 +02:00
#' # 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 equal:
2020-12-27 23:19:41 +01:00
#' # (though the row names on the first are more correct)
2020-09-29 23:35:46 +02:00
#' example_isolates %>% filter_carbapenems("R", "all")
#' example_isolates %>% filter(across(carbapenems(), ~. == "R"))
#' }
2020-07-28 18:39:57 +02:00
#' }
2019-08-12 14:48:09 +02:00
filter_ab_class <- function ( x ,
2019-03-05 22:47:42 +01:00
ab_class ,
result = NULL ,
scope = " any" ,
... ) {
2020-10-19 17:09:19 +02:00
.call_depth <- list ( ... ) $ `.call_depth`
if ( is.null ( .call_depth ) ) {
.call_depth <- 0
}
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 )
meet_criteria ( result , allow_class = " character" , has_length = c ( 1 , 2 , 3 ) , 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 )
2020-02-14 19:54:13 +01:00
check_dataset_integrity ( )
2020-10-19 17:09:19 +02:00
2020-06-02 16:05:56 +02:00
# save to return later
x_class <- class ( x )
2020-06-03 11:48:00 +02:00
x.bak <- x
2020-06-02 16:05:56 +02:00
x <- as.data.frame ( x , stringsAsFactors = FALSE )
2019-03-05 22:47:42 +01:00
if ( is.null ( result ) ) {
result <- c ( " S" , " I" , " R" )
}
2020-06-03 11:48:00 +02:00
# make result = "SI" works too:
2019-03-26 14:24:03 +01:00
result <- unlist ( strsplit ( result , " " ) )
2020-05-16 13:05:47 +02:00
2020-07-12 11:43:31 +02:00
stop_ifnot ( all ( result %in% c ( " S" , " I" , " R" ) ) , " `result` must be one or more of: 'S', 'I', 'R'" )
stop_ifnot ( all ( scope %in% c ( " any" , " all" ) ) , " `scope` must be one of: 'any', 'all'" )
2020-05-16 13:05:47 +02:00
2020-06-03 11:48:00 +02:00
# get all columns in data with names that resemble antibiotics
2020-09-24 00:30:11 +02:00
ab_in_data <- get_column_abx ( x , info = FALSE )
2020-06-03 11:48:00 +02:00
if ( length ( ab_in_data ) == 0 ) {
2020-10-27 15:56:51 +01:00
message_ ( " No columns with class <rsi> found (see ?as.rsi), data left unchanged." )
2020-06-03 11:48:00 +02:00
return ( x.bak )
}
# get reference data
2020-06-05 13:56:05 +02:00
ab_class.bak <- ab_class
2020-06-03 11:48:00 +02:00
ab_class <- gsub ( " [^a-zA-Z0-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 )
2019-08-12 14:48:09 +02:00
ab_group <- find_ab_group ( ab_class )
2020-06-05 13:56:05 +02:00
if ( ab_group == " " ) {
2020-10-27 15:56:51 +01:00
message_ ( " Unknown antimicrobial class '" , ab_class.bak , " ', data left unchanged." )
2020-06-05 13:56:05 +02:00
return ( x.bak )
}
2020-06-03 11:48:00 +02:00
# 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 ) {
2020-10-27 15:56:51 +01:00
message_ ( " NOTE: no antimicrobial agents of class " , ab_group ,
" found (such as " , find_ab_names ( ab_class , 2 ) ,
" ), data left unchanged." )
2020-06-03 11:48:00 +02:00
return ( x.bak )
}
2020-05-16 13:05:47 +02:00
2020-06-03 11:48:00 +02:00
if ( length ( result ) == 1 ) {
operator <- " is "
} else {
operator <- " is one of "
}
if ( scope == " any" ) {
scope_txt <- " or "
scope_fn <- any
} else {
scope_txt <- " and "
scope_fn <- all
if ( length ( agents ) > 1 ) {
operator <- gsub ( " is" , " are" , operator )
2019-03-05 22:47:42 +01:00
}
2020-06-03 11:48:00 +02:00
}
if ( length ( agents ) > 1 ) {
scope <- paste ( scope , " of columns " )
2019-03-05 22:47:42 +01:00
} else {
2020-06-03 11:48:00 +02:00
scope <- " column "
2019-03-05 22:47:42 +01:00
}
2020-06-03 11:48:00 +02:00
# sort columns on official name
agents <- agents [order ( ab_name ( names ( agents ) , language = NULL ) ) ]
2020-10-27 15:56:51 +01:00
message_ ( " Filtering on " , ab_group , " : " , scope ,
paste ( paste0 ( " `" , font_bold ( agents , collapse = NULL ) ,
" ` (" , ab_name ( names ( agents ) , tolower = TRUE , language = NULL ) , " )" ) ,
collapse = scope_txt ) ,
operator , toString ( result ) , as_note = FALSE )
2020-11-11 16:49:27 +01:00
x_transposed <- as.list ( as.data.frame ( t ( x [ , agents , drop = FALSE ] ) , stringsAsFactors = FALSE ) )
2020-12-28 22:24:33 +01:00
filtered <- vapply ( FUN.VALUE = logical ( 1 ) , x_transposed , function ( y ) scope_fn ( y %in% result , na.rm = TRUE ) )
2020-06-03 11:48:00 +02:00
x <- x [which ( filtered ) , , drop = FALSE ]
2020-06-02 16:05:56 +02:00
class ( x ) <- x_class
x
2019-03-05 22:47:42 +01:00
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_aminoglycosides <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " aminoglycoside" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_carbapenems <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " carbapenem" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_cephalosporins <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " cephalosporin" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_1st_cephalosporins <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
ab_class = " cephalosporins (1st gen.)" ,
2019-03-05 22:47:42 +01:00
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_2nd_cephalosporins <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
ab_class = " cephalosporins (2nd gen.)" ,
2019-03-05 22:47:42 +01:00
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_3rd_cephalosporins <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
ab_class = " cephalosporins (3rd gen.)" ,
2019-03-05 22:47:42 +01:00
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_4th_cephalosporins <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
ab_class = " cephalosporins (4th gen.)" ,
2019-03-05 22:47:42 +01:00
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_5th_cephalosporins <- function ( x ,
result = NULL ,
scope = " any" ,
... ) {
filter_ab_class ( x = x ,
ab_class = " cephalosporins (5th gen.)" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-08-12 14:48:09 +02:00
... )
}
#' @rdname filter_ab_class
#' @export
filter_fluoroquinolones <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " fluoroquinolone" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_glycopeptides <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " glycopeptide" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_macrolides <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " macrolide" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
2020-06-03 11:48:00 +02:00
#' @rdname filter_ab_class
#' @export
filter_penicillins <- function ( x ,
result = NULL ,
scope = " any" ,
... ) {
filter_ab_class ( x = x ,
ab_class = " penicillin" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2020-06-03 11:48:00 +02:00
... )
}
2019-03-05 22:47:42 +01:00
#' @rdname filter_ab_class
#' @export
2019-08-12 14:48:09 +02:00
filter_tetracyclines <- function ( x ,
2019-03-05 22:47:42 +01:00
result = NULL ,
scope = " any" ,
... ) {
2019-08-12 14:48:09 +02:00
filter_ab_class ( x = x ,
2019-03-05 22:47:42 +01:00
ab_class = " tetracycline" ,
result = result ,
scope = scope ,
2020-10-19 17:09:19 +02:00
.call_depth = 1 ,
2019-03-05 22:47:42 +01:00
... )
}
2019-08-12 14:48:09 +02:00
find_ab_group <- function ( ab_class ) {
2020-06-17 01:39:30 +02:00
ab_class <- gsub ( " [^a-zA-Z0-9]" , " .*" , ab_class )
2019-03-26 14:24:03 +01:00
ifelse ( ab_class %in% c ( " aminoglycoside" ,
" carbapenem" ,
" cephalosporin" ,
" fluoroquinolone" ,
" glycopeptide" ,
" macrolide" ,
" tetracycline" ) ,
paste0 ( ab_class , " s" ) ,
2020-09-18 16:05:53 +02:00
antibiotics %pm>%
2020-05-16 13:05:47 +02:00
subset ( group %like% ab_class |
atc_group1 %like% ab_class |
2020-09-18 16:05:53 +02:00
atc_group2 %like% ab_class ) %pm>%
pm_pull ( group ) %pm>%
unique ( ) %pm>%
tolower ( ) %pm>%
sort ( ) %pm>%
2019-03-26 14:24:03 +01:00
paste ( collapse = " /" )
)
2019-03-05 22:47:42 +01:00
}
2020-05-16 13:05:47 +02:00
2020-06-03 11:48:00 +02:00
find_ab_names <- function ( ab_group , n = 3 ) {
2020-06-17 01:39:30 +02:00
ab_group <- gsub ( " [^a-zA-Z0-9]" , " .*" , ab_group )
drugs <- antibiotics [which ( antibiotics $ group %like% ab_group & ! antibiotics $ ab %like% " [0-9]$" ) , ] $ name
2020-06-03 11:48:00 +02:00
paste0 ( sort ( ab_name ( sample ( drugs , size = min ( n , length ( drugs ) ) , replace = FALSE ) ,
tolower = TRUE , language = NULL ) ) ,
2020-05-16 13:05:47 +02:00
collapse = " , " )
}