class)
cospi <- function(...) 1
diff --git a/R/ab_class_selectors.R b/R/ab_class_selectors.R
index 7e647a9a..a29608f2 100644
--- a/R/ab_class_selectors.R
+++ b/R/ab_class_selectors.R
@@ -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)
}
diff --git a/R/eucast_rules.R b/R/eucast_rules.R
index 1060823d..cfa3c3bd 100755
--- a/R/eucast_rules.R
+++ b/R/eucast_rules.R
@@ -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>%
diff --git a/R/filter_ab_class.R b/R/filter_ab_class.R
index 12271640..7e9f5db8 100644
--- a/R/filter_ab_class.R
+++ b/R/filter_ab_class.R
@@ -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),
diff --git a/R/pca.R b/R/pca.R
index 570d79da..7fef85b6 100755
--- a/R/pca.R
+++ b/R/pca.R
@@ -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 {
diff --git a/data-raw/AMR_latest.tar.gz b/data-raw/AMR_latest.tar.gz
index f071bed6..1818c5ea 100644
Binary files a/data-raw/AMR_latest.tar.gz and b/data-raw/AMR_latest.tar.gz differ
diff --git a/data-raw/_install_deps.R b/data-raw/_install_deps.R
index c403e8ed..edb870df 100644
--- a/data-raw/_install_deps.R
+++ b/data-raw/_install_deps.R
@@ -26,11 +26,9 @@
install.packages("data-raw/AMR_latest.tar.gz", dependencies = FALSE)
# some old R instances have trouble installing tinytest, so we ship it too
-# R < 3.2 does not contain trimws(), which is part of this script and of a tinytest script
-trimws <- AMR:::trimws
-install.packages("data-raw/tinytest_1.2.4.tar.gz")
+install.packages("data-raw/tinytest_1.2.4.patched.tar.gz")
-pkg_suggests <- trimws(unlist(strsplit(packageDescription("AMR")$Suggests, ",(\n)?")))
+pkg_suggests <- AMR:::trimws(unlist(strsplit(packageDescription("AMR")$Suggests, ",(\n)?")))
to_install <- pkg_suggests[!pkg_suggests %in% rownames(utils::installed.packages())]
to_update <- as.data.frame(utils::old.packages(repos = "https://cran.rstudio.com/"), stringsAsFactors = FALSE)
diff --git a/data-raw/tinytest_1.2.4.patched.tar.gz b/data-raw/tinytest_1.2.4.patched.tar.gz
new file mode 100644
index 00000000..c1964685
Binary files /dev/null and b/data-raw/tinytest_1.2.4.patched.tar.gz differ
diff --git a/data-raw/tinytest_1.2.4.tar.gz b/data-raw/tinytest_1.2.4.tar.gz
deleted file mode 100644
index 27ea2af5..00000000
Binary files a/data-raw/tinytest_1.2.4.tar.gz and /dev/null differ
diff --git a/docs/404.html b/docs/404.html
index df253600..1363f01f 100644
--- a/docs/404.html
+++ b/docs/404.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html
index df173321..9adf2a4d 100644
--- a/docs/LICENSE-text.html
+++ b/docs/LICENSE-text.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
diff --git a/docs/articles/datasets.html b/docs/articles/datasets.html
index 363d22cd..c2db7e9e 100644
--- a/docs/articles/datasets.html
+++ b/docs/articles/datasets.html
@@ -39,7 +39,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
diff --git a/docs/articles/index.html b/docs/articles/index.html
index 27bfce39..e249e9b2 100644
--- a/docs/articles/index.html
+++ b/docs/articles/index.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
diff --git a/docs/authors.html b/docs/authors.html
index 6e7f4153..6913194a 100644
--- a/docs/authors.html
+++ b/docs/authors.html
@@ -81,7 +81,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
diff --git a/docs/index.html b/docs/index.html
index e4c6c913..9e95c72a 100644
--- a/docs/index.html
+++ b/docs/index.html
@@ -42,7 +42,7 @@
AMR (for R)
- 1.6.0.9044
+ 1.6.0.9047
@@ -221,13 +221,13 @@
mutate(bacteria = mo_fullname(mo)) %>%
filter(mo_is_gram_negative(), mo_is_intrinsic_resistant(ab = "cefotax")) %>%
select(bacteria, aminoglycosides(), carbapenems())
-#> NOTE: Using column 'mo' as input for mo_is_gram_negative()
-#> NOTE: Using column 'mo' as input for mo_is_intrinsic_resistant()
-#> NOTE: Determining intrinsic resistance based on 'EUCAST Expert Rules' and
-#> 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.2 (2020).
-#> Selecting aminoglycosides: columns 'AMK' (amikacin), 'GEN' (gentamicin),
-#> 'KAN' (kanamycin) and 'TOB' (tobramycin)
-#> Selecting carbapenems: columns 'IPM' (imipenem) and 'MEM' (meropenem)
+#> ℹ Using column 'mo' as input for mo_is_gram_negative()
+#> ℹ Using column 'mo' as input for mo_is_intrinsic_resistant()
+#> ℹ Determining intrinsic resistance based on 'EUCAST Expert Rules' and 'EUCAST Intrinsic
+#> Resistance and Unusual Phenotypes' v3.2 (2020)
+#> ℹ Applying `aminoglycosides()`: selecting columns 'AMK' (amikacin), 'GEN' (gentamicin), 'KAN'
+#> (kanamycin) and 'TOB' (tobramycin)
+#> ℹ Applying `carbapenems()`: selecting columns 'IPM' (imipenem) and 'MEM' (meropenem)
With only having defined a row filter on Gram-negative bacteria with intrinsic resistance to cefotaxime (mo_is_gram_negative()
and mo_is_intrinsic_resistant()
) and a column selection on two antibiotic groups (aminoglycosides()
and carbapenems()
), the reference data about all microorganisms and all antibiotics in the AMR
package make sure you get what you meant: