P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 14:01:55 +02:00
Code Releases Activity

(v1.6.0.9047) filter_ab_class() fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-05-18 11:29:31 +02:00
parent 7028dcfa5b
commit 6920c0be41
29 changed files with 226 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
R/aa_helper_functions.R
View File

@ -493,14 +493,30 @@ dataset_UTF8_to_ASCII <- function(df) {
}
# for eucast_rules() and mdro(), creates markdown output with URLs and names
create_ab_documentation <- function(ab) {
create_eucast_ab_documentation <- function() {
x <- trimws(unique(toupper(unlist(strsplit(eucast_rules_file$then_change_these_antibiotics, ",")))))
ab <- character()
for (val in x) {
if (val %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_internals.R, such as `CARBAPENEMS`
val <- eval(parse(text = val), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {
stop_("antimicrobial agent (group) not found in EUCAST rules file: ", val.bak, call = FALSE)
}
ab <- c(ab, val)
}
ab <- unique(ab)
atcs <- ab_atc(ab)
# only keep ABx with an ATC code:
ab <- ab[!is.na(atcs)]
ab_names <- ab_name(ab, language = NULL, tolower = TRUE)
ab <- ab[order(ab_names)]
ab_names <- ab_names[order(ab_names)]
atcs <- ab_atc(ab)
atcs[!is.na(atcs)] <- paste0("[", atcs[!is.na(atcs)], "](", ab_url(ab[!is.na(atcs)]), ")")
atcs[is.na(atcs)] <- "no ATC code"
out <- paste0(ab_names, " (`", ab, "`, ", atcs, ")", collapse = ", ")
atc_txt <- paste0("[", atcs[!is.na(atcs)], "](", ab_url(ab), ")")
out <- paste0(ab_names, " (`", ab, "`, ", atc_txt, ")", collapse = ", ")
substr(out, 1, 1) <- toupper(substr(out, 1, 1))
out
}
@ -638,9 +654,10 @@ meet_criteria <- function(object,
object <- tolower(object)
is_in <- tolower(is_in)
}
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name,
"` must be ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, "either ", ""),
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name, "` ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ",
"must only contain values "),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth)
@ -696,7 +713,7 @@ get_current_data <- function(arg_name, call) {
}
}
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2) {
if (current_R_older_than(3.2)) {
# R-3.0 and R-3.1 do not have an `x` element in the call stack, rendering this function useless
if (is.na(arg_name)) {
# like in carbapenems() etc.
@ -1157,6 +1174,10 @@ time_track <- function(name = NULL) {
paste("(until now:", trimws(round(as.numeric(Sys.time()) * 1000) - pkg_env$time_start), "ms)")
}
current_R_older_than <- function(version) {
as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < version
}
# prevent dependency on package 'backports' ----
# these functions were not available in previous versions of R (last checked: R 4.0.5)
# see here for the full list: https://github.com/r-lib/backports
@ -1205,7 +1226,7 @@ lengths <- function(x, use.names = TRUE) {
vapply(x, length, FUN.VALUE = NA_integer_, USE.NAMES = use.names)
}
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.1) {
if (current_R_older_than(3.1)) {
# R-3.0 does not contain these functions, set them here to prevent installation failure
# (required for extension of the <mic> class)
cospi <- function(...) 1

8
R/ab_class_selectors.R
View File

@ -183,7 +183,7 @@ ab_selector <- function(ab_class,
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = 1)
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2) {
if (current_R_older_than(3.2)) {
warning_("antibiotic class selectors such as ", function_name,
"() require R version 3.2 or later - you have ", R.version.string,
call = FALSE)
@ -229,11 +229,9 @@ 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_("Selecting ", ab_group, ": ",
message_("Applying `", function_name, "()`: selecting ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE),
as_note = FALSE,
extra_indent = 6)
vector_and(agents_formatted, quotes = FALSE))
}
remember_thrown_message(function_name)
}

18
R/eucast_rules.R
View File

@ -93,9 +93,9 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @section Antibiotics:
#' To define antibiotics column names, leave as it is to determine it automatically with [guess_ab_col()] or input a text (case-insensitive), or use `NULL` to skip a column (e.g. `TIC = NULL` to skip ticarcillin). Manually defined but non-existing columns will be skipped with a warning.
#'
#' The following antibiotics are used for the functions [eucast_rules()] and [mdro()]. These are shown below in the format 'name (`antimicrobial ID`, [ATC code](https://www.whocc.no/atc/structure_and_principles/))', sorted alphabetically:
#' The following antibiotics are eligible for the functions [eucast_rules()] and [mdro()]. These are shown below in the format 'name (`antimicrobial ID`, [ATC code](https://www.whocc.no/atc/structure_and_principles/))', sorted alphabetically:
#'
#' `r create_ab_documentation(c("AMC", "AMK", "AMP", "AMX", "APL", "APX", "ATM", "AVB", "AVO", "AZD", "AZL", "AZM", "BAM", "BPR", "CAC", "CAT", "CAZ", "CCP", "CCV", "CCX", "CDC", "CDR", "CDZ", "CEC", "CED", "CEI", "CEM", "CEP", "CFM", "CFM1", "CFP", "CFR", "CFS", "CFZ", "CHE", "CHL", "CIC", "CID", "CIP", "CLI", "CLM", "CLO", "CLR", "CMX", "CMZ", "CND", "COL", "CPD", "CPI", "CPL", "CPM", "CPO", "CPR", "CPT", "CPX", "CRB", "CRD", "CRN", "CRO", "CSL", "CTB", "CTC", "CTF", "CTL", "CTS", "CTT", "CTX", "CTZ", "CXM", "CYC", "CZA", "CZD", "CZO", "CZP", "CZX", "DAL", "DAP", "DIC", "DIR", "DIT", "DIX", "DIZ", "DKB", "DOR", "DOX", "ENX", "EPC", "ERY", "ETP", "FEP", "FLC", "FLE", "FLR1", "FOS", "FOV", "FOX", "FOX1", "FUS", "GAT", "GEM", "GEN", "GRX", "HAP", "HET", "IPM", "ISE", "JOS", "KAN", "LEN", "LEX", "LIN", "LNZ", "LOM", "LOR", "LTM", "LVX", "MAN", "MCM", "MEC", "MEM", "MET", "MEV", "MEZ", "MFX", "MID", "MNO", "MTM", "NAC", "NAF", "NAL", "NEO", "NET", "NIT", "NOR", "NOV", "NVA", "OFX", "OLE", "ORI", "OXA", "PAZ", "PEF", "PEN", "PHE", "PHN", "PIP", "PLB", "PME", "PNM", "PRC", "PRI", "PRL", "PRP", "PRU", "PVM", "QDA", "RAM", "RFL", "RID", "RIF", "ROK", "RST", "RXT", "SAM", "SBC", "SDI", "SDM", "SIS", "SLF", "SLF1", "SLF10", "SLF11", "SLF12", "SLF13", "SLF2", "SLF3", "SLF4", "SLF5", "SLF6", "SLF7", "SLF8", "SLF9", "SLT1", "SLT2", "SLT3", "SLT4", "SLT5", "SLT6", "SMX", "SPI", "SPX", "SRX", "STR", "STR1", "SUD", "SUL", "SUT", "SXT", "SZO", "TAL", "TAZ", "TCC", "TCM", "TCY", "TEC", "TEM", "TGC", "THA", "TIC", "TIO", "TLT", "TLV", "TMP", "TMX", "TOB", "TRL", "TVA", "TZD", "TZP", "VAN"))`
#' `r create_eucast_ab_documentation()`
#' @aliases EUCAST
#' @rdname eucast_rules
#' @export
@ -317,21 +317,23 @@ eucast_rules <- function(x,
# Some helper functions ---------------------------------------------------
get_antibiotic_columns <- function(x, cols_ab) {
x <- strsplit(x, ", *")[[1]]
x <- trimws(unique(toupper(unlist(strsplit(x, ",")))))
x_new <- character()
for (val in x) {
if (toupper(val) %in% ls(envir = asNamespace("AMR"))) {
if (val %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_internals.R, such as `CARBAPENEMS`
val <- eval(parse(text = toupper(val)), envir = asNamespace("AMR"))
} else if (toupper(val) %in% AB_lookup$ab) {
val <- eval(parse(text = val), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {
stop_("antimicrobial agent (group) not found in EUCAST rules file: ", val, call = FALSE)
stop_("unknown antimicrobial agent (group) in EUCAST rules file: ", val, call = FALSE)
}
x_new <- c(x_new, val)
}
cols_ab[match(x_new, names(cols_ab))]
x_new <- unique(x_new)
out <- cols_ab[match(x_new, names(cols_ab))]
out[!is.na(out)]
}
get_antibiotic_names <- function(x) {
x <- x %pm>%

64
R/filter_ab_class.R
View File

@ -40,9 +40,12 @@
#' @seealso [antibiotic_class_selectors()] for the `select()` equivalent.
#' @export
#' @examples
#' filter_aminoglycosides(example_isolates)
#'
#' 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
@ -78,6 +81,7 @@
#' 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,
@ -90,15 +94,29 @@ filter_ab_class <- function(x,
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)
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), allow_NULL = TRUE, .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)
@ -109,9 +127,6 @@ filter_ab_class <- function(x,
# make result = "SI" works too:
result <- unlist(strsplit(result, ""))
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'")
# 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)
@ -180,16 +195,18 @@ filter_ab_class <- function(x,
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
" (", agents_names[need_name], ")")
message_("Filtering on ", ab_group, ": ", scope,
message_("Applying `", .fn, "()`: ", scope,
vector_or(agents_formatted, quotes = FALSE, last_sep = scope_txt),
operator, " ", vector_or(result, quotes = TRUE),
as_note = FALSE,
extra_indent = 6)
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))
# this returns the original data with the filtering, also preserving attributes (such as dplyr groups)
x.bak[which(filtered), , drop = FALSE]
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
@ -205,6 +222,7 @@ filter_aminoglycosides <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_aminoglycosides",
...)
}
@ -221,6 +239,7 @@ filter_betalactams <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_betalactams",
...)
}
#' @rdname filter_ab_class
@ -236,6 +255,7 @@ filter_carbapenems <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_carbapenems",
...)
}
@ -252,6 +272,7 @@ filter_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_cephalosporins",
...)
}
@ -268,6 +289,7 @@ filter_1st_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_1st_cephalosporins",
...)
}
@ -284,6 +306,7 @@ filter_2nd_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_2nd_cephalosporins",
...)
}
@ -300,6 +323,7 @@ filter_3rd_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_3rd_cephalosporins",
...)
}
@ -316,6 +340,7 @@ filter_4th_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_4th_cephalosporins",
...)
}
@ -332,6 +357,7 @@ filter_5th_cephalosporins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_5th_cephalosporins",
...)
}
@ -348,6 +374,7 @@ filter_fluoroquinolones <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_fluoroquinolones",
...)
}
@ -364,6 +391,7 @@ filter_glycopeptides <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_glycopeptides",
...)
}
@ -380,6 +408,7 @@ filter_macrolides <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_macrolides",
...)
}
@ -396,6 +425,7 @@ filter_oxazolidinones <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_oxazolidinones",
...)
}
@ -412,6 +442,7 @@ filter_penicillins <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_penicillins",
...)
}
@ -428,6 +459,7 @@ filter_tetracyclines <- function(x,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_tetracyclines",
...)
}
@ -448,7 +480,7 @@ find_ab_group <- function(ab_class) {
subset(group %like% ab_class |
atc_group1 %like% ab_class |
atc_group2 %like% ab_class) %pm>%
pm_pull(group) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
sort() %pm>%
@ -466,7 +498,9 @@ find_ab_names <- function(ab_group, n = 3) {
antibiotics$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- antibiotics[which(antibiotics$group %like% ab_group &
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),

4
R/pca.R
View File

@ -106,7 +106,7 @@ pca <- function(x,
tryCatch(colnames(x) <- as.character(dots)[2:length(dots)],
error = function(e) warning("column names could not be set"))
# keep only [numeric] columns
# keep only numeric columns
x <- x[, vapply(FUN.VALUE = logical(1), x, function(y) is.numeric(y))]
# bind the data set with the non-numeric columns
x <- cbind(x.bak[, vapply(FUN.VALUE = logical(1), x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
@ -120,7 +120,7 @@ pca <- function(x,
message_("Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), ".")
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.4) {
if (current_R_older_than(3.4)) {
# stats::prcomp prior to 3.4.0 does not have the 'rank.' argument
pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol)
} else {