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

(v0.7.1.9036) preserve ab/mo classes in subsetting

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-08-12 14:48:09 +02:00
parent 1d423cca89
commit bd252a2984
23 changed files with 237 additions and 181 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
R/ab.R
View File

@ -279,12 +279,13 @@ as.data.frame.ab <- function (x, ...) {
}
}
#' @exportMethod pull.ab
#' @exportMethod [.ab
#' @export
#' @importFrom dplyr pull
#' @noRd
pull.ab <- function(.data, ...) {
pull(as.data.frame(.data), ...)
"[.ab" <- function (x, ...) {
# this function is needed to preserve the "ab" class for any subsetting, like df %>% filter(...)
y <- NextMethod()
structure(y, class = "ab")
}
#' @importFrom pillar type_sum

14
R/disk.R
View File

@ -90,3 +90,17 @@ print.disk <- function(x, ...) {
cat("Class 'disk'\n")
print(as.integer(x), quote = FALSE)
}
#' @importFrom pillar type_sum
#' @export
type_sum.disk <- function(x) {
"disk"
}
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.disk <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_na(NA)
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 3)
}

119
R/filter_ab_class.R
View File

@ -22,12 +22,12 @@
#' Filter isolates on result in antibiotic class
#'
#' Filter isolates on results in specific antibiotic variables based on their class (ATC groups). This makes it easy to get a list of isolates that were tested for e.g. any aminoglycoside.
#' @param tbl a data set
#' @param ab_class an antimicrobial class, like \code{"carbapenems"}. More specifically, this should be a text that can be found in a 4th level ATC group (chemical subgroup) or a 5th level ATC group (chemical substance), please see \href{https://www.whocc.no/atc/structure_and_principles/}{this explanation on the WHOCC website}.
#' @param x a data set
#' @param ab_class an antimicrobial class, like \code{"carbapenems"}, as can be found in \code{AMR::antibiotics$group}
#' @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 \code{"any"} (default) or \code{"all"}
#' @param ... parameters passed on to \code{\link[dplyr]{filter_at}}
#' @details The \code{\link{antibiotics}} data set will be searched for \code{ab_class} in the columns \code{atc_group1} and \code{atc_group2} (case-insensitive). Next, \code{tbl} will be checked for column names with a value in any abbreviations, codes or official names found in the \code{antibiotics} data set.
#' @details The \code{group} column in \code{\link{antibiotics}} data set will be searched for \code{ab_class} (case-insensitive). If no results are found, the \code{atc_group1} and \code{atc_group2} columns will be searched. Next, \code{x} will be checked for column names with a value in any abbreviations, codes or official names found in the \code{antibiotics} data set.
#' @rdname filter_ab_class
#' @keywords filter fillter_class
#' @importFrom dplyr filter_at %>% select vars any_vars all_vars
@ -62,7 +62,7 @@
#' septic_patients %>%
#' filter_aminoglycosides("R", "all") %>%
#' filter_fluoroquinolones("R", "all")
filter_ab_class <- function(tbl,
filter_ab_class <- function(x,
ab_class,
result = NULL,
scope = "any",
@ -71,7 +71,7 @@ filter_ab_class <- function(tbl,
if (is.null(result)) {
result <- c("S", "I", "R")
}
# make result = "IR" work too:
# make result = "SI" work too:
result <- unlist(strsplit(result, ""))
if (!all(result %in% c("S", "I", "R"))) {
@ -81,8 +81,8 @@ filter_ab_class <- function(tbl,
stop("`scope` must be one of: any, all", call. = FALSE)
}
vars_df <- colnames(tbl)[tolower(colnames(tbl)) %in% tolower(ab_class_vars(ab_class))]
atc_groups <- ab_class_atcgroups(ab_class)
vars_df <- colnames(x)[tolower(colnames(x)) %in% tolower(ab_class_vars(ab_class))]
ab_group <- find_ab_group(ab_class)
if (length(vars_df) > 0) {
if (length(result) == 1) {
@ -101,29 +101,29 @@ filter_ab_class <- function(tbl,
}
}
if (length(vars_df) > 1) {
scope <- paste(scope, "of ")
scope <- paste(scope, "of columns ")
} else {
scope <- ""
scope <- "column "
}
message(blue(paste0("Filtering on ", atc_groups, ": ", scope,
message(blue(paste0("Filtering on ", ab_group, ": ", scope,
paste(bold(paste0("`", vars_df, "`")), collapse = scope_txt), operator, toString(result))))
tbl %>%
x %>%
filter_at(vars(vars_df),
scope_fn(. %in% result),
...)
} else {
warning(paste0("no antibiotics of class ", atc_groups, " found, leaving data unchanged"), call. = FALSE)
tbl
warning(paste0("no antibiotics of class ", ab_group, " found, leaving data unchanged"), call. = FALSE)
x
}
}
#' @rdname filter_ab_class
#' @export
filter_aminoglycosides <- function(tbl,
filter_aminoglycosides <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
@ -132,11 +132,11 @@ filter_aminoglycosides <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_carbapenems <- function(tbl,
filter_carbapenems <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "carbapenem",
result = result,
scope = scope,
@ -145,11 +145,11 @@ filter_carbapenems <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_cephalosporins <- function(tbl,
filter_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "cephalosporin",
result = result,
scope = scope,
@ -158,12 +158,12 @@ filter_cephalosporins <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_1st_cephalosporins <- function(tbl,
filter_1st_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
ab_class = "first-generation cephalosporin",
filter_ab_class(x = x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
...)
@ -171,12 +171,12 @@ filter_1st_cephalosporins <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_2nd_cephalosporins <- function(tbl,
filter_2nd_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
ab_class = "second-generation cephalosporin",
filter_ab_class(x = x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
...)
@ -184,12 +184,12 @@ filter_2nd_cephalosporins <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_3rd_cephalosporins <- function(tbl,
filter_3rd_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
ab_class = "third-generation cephalosporin",
filter_ab_class(x = x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
...)
@ -197,12 +197,12 @@ filter_3rd_cephalosporins <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_4th_cephalosporins <- function(tbl,
filter_4th_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
ab_class = "fourth-generation cephalosporin",
filter_ab_class(x = x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
...)
@ -210,11 +210,24 @@ filter_4th_cephalosporins <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_fluoroquinolones <- function(tbl,
filter_5th_cephalosporins <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
...)
}
#' @rdname filter_ab_class
#' @export
filter_fluoroquinolones <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
@ -223,11 +236,11 @@ filter_fluoroquinolones <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_glycopeptides <- function(tbl,
filter_glycopeptides <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "glycopeptide",
result = result,
scope = scope,
@ -236,11 +249,11 @@ filter_glycopeptides <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_macrolides <- function(tbl,
filter_macrolides <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "macrolide",
result = result,
scope = scope,
@ -249,11 +262,11 @@ filter_macrolides <- function(tbl,
#' @rdname filter_ab_class
#' @export
filter_tetracyclines <- function(tbl,
filter_tetracyclines <- function(x,
result = NULL,
scope = "any",
...) {
filter_ab_class(tbl = tbl,
filter_ab_class(x = x,
ab_class = "tetracycline",
result = result,
scope = scope,
@ -262,8 +275,9 @@ filter_tetracyclines <- function(tbl,
#' @importFrom dplyr %>% filter_at vars any_vars select
ab_class_vars <- function(ab_class) {
ab_class <- gsub("[^a-z0-9]+", ".*", ab_class)
ab_vars <- AMR::antibiotics %>%
filter_at(vars(c("atc_group1", "atc_group2")), any_vars(. %like% ab_class)) %>%
filter(group %like% ab_class) %>%
select(ab:name, abbreviations, synonyms) %>%
unlist() %>%
as.matrix() %>%
@ -272,18 +286,29 @@ ab_class_vars <- function(ab_class) {
strsplit("|", fixed = TRUE) %>%
unlist() %>%
unique()
ab_vars[!is.na(ab_vars)]
ab_vars <- ab_vars[!ab_vars %in% c(NA, "", "NA") & nchar(ab_vars) > 2]
if (length(ab_vars) == 0) {
# try again, searching atc_group1 and atc_group2 columns
ab_vars <- AMR::antibiotics %>%
filter_at(vars(c("atc_group1", "atc_group2")), any_vars(. %like% ab_class)) %>%
select(ab:name, abbreviations, synonyms) %>%
unlist() %>%
as.matrix() %>%
as.character() %>%
paste(collapse = "|") %>%
strsplit("|", fixed = TRUE) %>%
unlist() %>%
unique()
ab_vars <- ab_vars[!ab_vars %in% c(NA, "", "NA") & nchar(ab_vars) > 2]
}
ab_vars
}
#' @importFrom dplyr %>% filter pull
ab_class_atcgroups <- function(ab_class) {
find_ab_group <- function(ab_class) {
ifelse(ab_class %in% c("aminoglycoside",
"carbapenem",
"cephalosporin",
"first-generation cephalosporin",
"second-generation cephalosporin",
"third-generation cephalosporin",
"fourth-generation cephalosporin",
"fluoroquinolone",
"glycopeptide",
"macrolide",
@ -291,7 +316,7 @@ ab_class_atcgroups <- function(ab_class) {
paste0(ab_class, "s"),
AMR::antibiotics %>%
filter(ab %in% ab_class_vars(ab_class)) %>%
pull("atc_group2") %>%
pull(group) %>%
unique() %>%
tolower() %>%
paste(collapse = "/")

2
R/mic.R
View File

@ -289,6 +289,6 @@ type_sum.mic <- function(x) {
#' @export
pillar_shaft.mic <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- NA
out[is.na(x)] <- pillar::style_na(NA)
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 4)
}

23
R/mo.R
View File

@ -1521,8 +1521,18 @@ type_sum.mo <- function(x) {
#' @export
pillar_shaft.mo <- function(x, ...) {
out <- format(x)
out[is.na(x)] <- pillar::style_na("NA")
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 11)
# grey out the kingdom (part before first "_")
first_parts <- unlist(lapply(gregexpr(pattern = '_', x[!is.na(x)], fixed = TRUE), min))
first_parts[first_parts < 0] <- 0
out[!is.na(x)] <- paste0(pillar::style_subtle(substr(x[!is.na(x)], 0, first_parts)),
substr(x[!is.na(x)], first_parts + 1, nchar(x)))
out[is.na(x)] <- pillar::style_na(" NA")
out[x == "UNKNOWN"] <- pillar::style_na(" UNKNOWN")
out <- gsub("_", pillar::style_subtle("_"), out)
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 12)
}
#' @exportMethod summary.mo
@ -1556,12 +1566,13 @@ as.data.frame.mo <- function(x, ...) {
}
}
#' @exportMethod pull.mo
#' @exportMethod [.mo
#' @export
#' @importFrom dplyr pull
#' @noRd
pull.mo <- function(.data, ...) {
pull(as.data.frame(.data), ...)
"[.mo" <- function (x, ...) {
# this function is needed to preserve the "mo" class for any subsetting, like df %>% filter(...)
y <- NextMethod()
to_class_mo(y)
}
#' @rdname as.mo

4
R/rsi.R
View File

@ -486,9 +486,9 @@ type_sum.rsi <- function(x) {
#' @export
pillar_shaft.rsi <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_subtle("NA")
out[is.na(x)] <- pillar::style_subtle(" NA")
out[x == "S"] <- bgGreen(white(" S "))
out[x == "I"] <- bgYellow(black(" I "))
out[x == "R"] <- bgRed(white(" R "))
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 3)
}