P281424
/
AMR
mirror of https://github.com/msberends/AMR
1
0
Fork 0
Code Releases Activity

(v1.6.0.9000) custom EUCAST rules

pull/67/head
dr. M.S. (Matthijs) Berends 2021-04-07 08:37:42 +02:00
parent 551f99dc8f
commit 7a3139f7cc
49 changed files with 1363 additions and 594 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.github/workflows/check.yaml vendored
View File

@ -66,8 +66,8 @@ jobs:
- {os: ubuntu-20.04, r: '3.5', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-20.04, r: '3.4', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-20.04, r: '3.3', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
# - {os: ubuntu-20.04, r: '3.2', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
# - {os: ubuntu-20.04, r: '3.1', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-20.04, r: '3.2', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-20.04, r: '3.1', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-20.04, r: '3.0', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
- {os: ubuntu-16.04, r: 'devel', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
@ -78,8 +78,8 @@ jobs:
- {os: ubuntu-16.04, r: '3.5', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.4', allowfail: false, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.3', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
# - {os: ubuntu-16.04, r: '3.2', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
# - {os: ubuntu-16.04, r: '3.1', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.2', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.1', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
- {os: ubuntu-16.04, r: '3.0', allowfail: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
env:
@ -162,7 +162,8 @@ jobs:
_R_CHECK_LENGTH_1_CONDITION_: verbose
_R_CHECK_LENGTH_1_LOGIC2_: verbose
run: |
R CMD check data-raw/AMR_latest.tar.gz --no-manual --no-build-vignettes
tar -xvf data-raw/AMR_latest.tar.gz
R CMD check AMR --no-manual --no-build-vignettes
- name: Show testthat output
if: always()

13
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.6.0
Date: 2021-03-14
Version: 1.6.0.9000
Date: 2021-04-07
Title: Antimicrobial Resistance Data Analysis
Authors@R: c(
person(role = c("aut", "cre"),
@ -35,11 +35,10 @@ Authors@R: c(
family = "Souverein", given = "Dennis", email = "d.souvereing@streeklabhaarlem.nl"),
person(role = "ctb",
family = "Underwood", given = "Anthony", email = "au3@sanger.ac.uk"))
Description: Functions to simplify the analysis and prediction of Antimicrobial
Resistance (AMR) and to work with microbial and antimicrobial properties by
using evidence-based methods, like those defined by Leclercq et al. (2013)
<doi:10.1111/j.1469-0691.2011.03703.x> and containing reference data such as
LPSN <doi:10.1099/ijsem.0.004332>.
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by
using evidence-based methods and reliable reference data such as LPSN
<doi:10.1099/ijsem.0.004332>.
Depends:
R (>= 3.0.0)
Suggests:

6
NAMESPACE
View File

@ -43,6 +43,8 @@ S3method(as.data.frame,ab)
S3method(as.data.frame,mo)
S3method(as.double,mic)
S3method(as.integer,mic)
S3method(as.list,custom_eucast_rules)
S3method(as.list,custom_mdro_guideline)
S3method(as.matrix,mic)
S3method(as.numeric,mic)
S3method(as.rsi,data.frame)
@ -57,6 +59,8 @@ S3method(barplot,disk)
S3method(barplot,mic)
S3method(barplot,rsi)
S3method(c,ab)
S3method(c,custom_eucast_rules)
S3method(c,custom_mdro_guideline)
S3method(c,disk)
S3method(c,mic)
S3method(c,mo)
@ -97,6 +101,7 @@ S3method(plot,rsi)
S3method(print,ab)
S3method(print,bug_drug_combinations)
S3method(print,catalogue_of_life_version)
S3method(print,custom_eucast_rules)
S3method(print,custom_mdro_guideline)
S3method(print,disk)
S3method(print,mic)
@ -184,6 +189,7 @@ export(count_all)
export(count_df)
export(count_resistant)
export(count_susceptible)
export(custom_eucast_rules)
export(custom_mdro_guideline)
export(eucast_dosage)
export(eucast_exceptional_phenotypes)

18
NEWS.md
View File

@ -1,5 +1,19 @@
# AMR 1.6.0
# AMR 1.6.0.9000
## <small>Last updated: 7 April 2021</small>
### New
* Function `custom_eucast_rules()` that brings support for custom AMR rules in `eucast_rules()`
# Changed
* Custom MDRO guidelines (`mdro()`, `custom_mdro_guideline()`):
* Custom MDRO guidelines can now be combined with other custom MDRO guidelines using `c()`
* Fix for applying the rules; in previous versions, rows were interpreted according to the last matched rule. Now, rows are interpreted according to the first matched rule
* Fix for `age_groups()` for persons aged zero
* The `example_isolates` data set now contains some (fictitious) zero-year old patients
* Fix for minor translation errors
* Printing of microbial codes in a `data.frame` or `tibble` now gives a warning if the data contains old microbial codes (from a previous AMR package version)
# AMR 1.6.0
### New
* Support for EUCAST Clinical Breakpoints v11.0 (2021), effective in the `eucast_rules()` function and in `as.rsi()` to interpret MIC and disk diffusion values. This is now the default guideline in this package.
@ -59,7 +73,7 @@
```
### Changed
* Updated the bacterial taxonomy to 3 March 2021 (using [LSPN](https://lpsn.dsmz.de))
* Updated the bacterial taxonomy to 3 March 2021 (using [LPSN](https://lpsn.dsmz.de))
* Added 3,372 new species and 1,523 existing species became synomyms
* The URL of a bacterial species (`mo_url()`) will now lead to https://lpsn.dsmz.de
* Big update for plotting classes `rsi`, `<mic>`, and `<disk>`:

18
R/aa_helper_functions.R
View File

@ -504,8 +504,8 @@ format_class <- function(class, plural) {
if ("matrix" %in% class) {
class <- "a matrix"
}
if ("isolate_identifier" %in% class) {
class <- "created with isolate_identifier()"
if ("custom_eucast_rules" %in% class) {
class <- "input created with `custom_eucast_rules()`"
}
if (any(c("mo", "ab", "rsi") %in% class)) {
class <- paste0("of class <", class[1L], ">")
@ -522,6 +522,7 @@ meet_criteria <- function(object,
looks_like = NULL,
is_in = NULL,
is_positive = NULL,
is_positive_or_zero = NULL,
is_finite = NULL,
contains_column_class = NULL,
allow_NULL = FALSE,
@ -594,9 +595,16 @@ meet_criteria <- function(object,
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a positive number",
"all be positive numbers"),
" (higher than zero)",
"be a number higher than zero",
"all be numbers higher than zero"),
call = call_depth)
}
if (!is.null(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number",
"all be zero or numbers higher than zero"),
call = call_depth)
}
if (!is.null(is_finite)) {

4
R/age.R
View File

@ -149,8 +149,8 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' }
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
meet_criteria(x, allow_class = c("numeric", "integer"), is_positive = TRUE, is_finite = TRUE)
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"), is_positive = TRUE, is_finite = TRUE)
meet_criteria(x, allow_class = c("numeric", "integer"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (any(x < 0, na.rm = TRUE)) {

247
R/custom_eucast_rules.R 100644
View File

@ -0,0 +1,247 @@
# ==================================================================== #
# 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/ #
# ==================================================================== #
#' Create Custom EUCAST Rules
#'
#' @inheritSection lifecycle Experimental Lifecycle
#' @param ... rules in formula notation, see *Examples*
#' @details
#' This documentation page will be updated shortly. **This function is experimental.**
#'
#' @section How it works:
#' ..
#'
#' It is also possible to define antibiotic groups instead of single antibiotics. The following groups are allowed (case-insensitive): `r vector_and(tolower(DEFINED_AB_GROUPS), quote = "``")`.
#' @export
#' @examples
#' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
#' eucast_rules(example_isolates,
#' rules = "custom",
#' custom_rules = x,
#' info = FALSE)
#'
#' # combine rule sets
#' x2 <- c(x,
#' custom_eucast_rules(TZP == "R" ~ carbapenems == "R"))
#' x2
custom_eucast_rules <- function(...) {
dots <- tryCatch(list(...),
error = function(e) "error")
stop_if(identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`")
n_dots <- length(dots)
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?custom_eucast_rules`.")
out <- vector("list", n_dots)
for (i in seq_len(n_dots)) {
stop_ifnot(inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`")
# Query
qry <- dots[[i]][[2]]
if (inherits(qry, "call")) {
qry <- as.expression(qry)
}
qry <- as.character(qry)
# these will prevent vectorisation, so replace them:
qry <- gsub("&&", "&", qry, fixed = TRUE)
qry <- gsub("||", "|", qry, fixed = TRUE)
# format nicely, setting spaces around operators
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
qry <- gsub(" ?, ?", ", ", qry)
qry <- gsub("'", "\"", qry, fixed = TRUE)
out[[i]]$query <- as.expression(qry)
# Resulting rule
result <- dots[[i]][[3]]
stop_ifnot(deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`")
result_group <- as.character(result)[[2]]
if (paste0(toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
result_group <- paste0(result_group, "s")
}
if (toupper(result_group) %in% DEFINED_AB_GROUPS) {
result_group <- eval(parse(text = toupper(result_group)), envir = asNamespace("AMR"))
} else {
result_group <- tryCatch(
suppressWarnings(as.ab(result_group,
fast_mode = TRUE,
info = FALSE,
flag_multiple_results = FALSE)),
error = function(e) NA_character_)
}
stop_if(any(is.na(result_group)),
"this result of rule ", i, " could not be translated to a single antimicrobial agent/group: \"",
as.character(result)[[2]], "\".\n\nThe input can be a name or code of an antimicrobial agent, or be one of: ",
vector_or(tolower(DEFINED_AB_GROUPS), quotes = FALSE), ".")
result_value <- as.character(result)[[3]]
result_value[result_value == "NA"] <- NA
stop_ifnot(result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA")
result_value <- as.rsi(result_value)
out[[i]]$result_group <- result_group
out[[i]]$result_value <- result_value
}
names(out) <- paste0("rule", seq_len(n_dots))
set_clean_class(out, new_class = c("custom_eucast_rules", "list"))
}
#' @method c custom_eucast_rules
#' @noRd
#' @export
c.custom_eucast_rules <- function(x, ...) {
if (length(list(...)) == 0) {
return(x)
}
out <- unclass(x)
for (e in list(...)) {
out <- c(out, unclass(e))
}
names(out) <- paste0("rule", seq_len(length(out)))
set_clean_class(out, new_class = c("custom_eucast_rules", "list"))
}
#' @method as.list custom_eucast_rules
#' @noRd
#' @export
as.list.custom_eucast_rules <- function(x, ...) {
c(x, ...)
}
#' @method print custom_eucast_rules
#' @export
#' @noRd
print.custom_eucast_rules <- function(x, ...) {
cat("A set of custom EUCAST rules:\n")
for (i in seq_len(length(x))) {
rule <- x[[i]]
rule$query <- format_custom_query_rule(rule$query)
if (rule$result_value == "R") {
val <- font_rsi_R_bg(font_black(" R "))
} else if (rule$result_value == "S") {
val <- font_rsi_S_bg(font_black(" S "))
} else {
val <- font_rsi_I_bg(font_black(" I "))
}
agents <- paste0(font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
collapse = NULL),
" (", rule$result_group, ")")
agents <- sort(agents)
rule_if <- word_wrap(paste0(i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
"set to {result}:"),
extra_indent = 5)
rule_if <- gsub("{result}", val, rule_if, fixed = TRUE)
rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5))
cat("\n ", rule_if, "\n", rule_then, "\n", sep = "")
}
}
run_custom_eucast_rules <- function(df, rule, info) {
n_dots <- length(rule)
stop_if(n_dots == 0, "no custom rules set", call = -2)
out <- character(length = NROW(df))
reasons <- character(length = NROW(df))
for (i in seq_len(n_dots)) {
qry <- tryCatch(eval(parse(text = rule[[i]]$query), envir = df, enclos = parent.frame()),
error = function(e) {
pkg_env$err_msg <- e$message
return("error")
})
if (identical(qry, "error")) {
warning_("in custom_eucast_rules(): rule ", i,
" (`", as.character(rule[[i]]$query), "`) was ignored because of this error message: ",
pkg_env$err_msg,
call = FALSE,
add_fn = font_red)
next
}
stop_ifnot(is.logical(qry), "in custom_eucast_rules(): rule ", i, " (`", rule[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE), call = FALSE)
new_eucasts <- which(qry == TRUE & out == "")
if (info == TRUE) {
cat(word_wrap("- Custom EUCAST rule ", i, ": `", as.character(rule[[i]]$query),
"` (", length(new_eucasts), " rows matched)"), "\n", sep = "")
}
val <- rule[[i]]$value
out[new_eucasts] <- val
reasons[new_eucasts] <- paste0("matched rule ", gsub("rule", "", names(rule)[i]), ": ", as.character(rule[[i]]$query))
}
out[out == ""] <- "Negative"
reasons[out == "Negative"] <- "no rules matched"
if (isTRUE(attributes(rule)$as_factor)) {
out <- factor(out, levels = attributes(rule)$values, ordered = TRUE)
}
columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df)] == "R"))
columns_nonsusceptible <- vapply(FUN.VALUE = character(1),
columns_nonsusceptible,
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " "))
columns_nonsusceptible[is.na(out)] <- NA_character_
data.frame(row_number = seq_len(NROW(df)),
EUCAST = out,
reason = reasons,
columns_nonsusceptible = columns_nonsusceptible,
stringsAsFactors = FALSE)
}
format_custom_query_rule <- function(query, colours = has_colour()) {
query <- gsub(" & ", font_black(font_bold(" and ")), query, fixed = TRUE)
query <- gsub(" | ", font_black(" or "), query, fixed = TRUE)
query <- gsub(" + ", font_black(" plus "), query, fixed = TRUE)
query <- gsub(" - ", font_black(" minus "), query, fixed = TRUE)
query <- gsub(" / ", font_black(" divided by "), query, fixed = TRUE)
query <- gsub(" * ", font_black(" times "), query, fixed = TRUE)
query <- gsub(" == ", font_black(" is "), query, fixed = TRUE)
query <- gsub(" > ", font_black(" is higher than "), query, fixed = TRUE)
query <- gsub(" < ", font_black(" is lower than "), query, fixed = TRUE)
query <- gsub(" >= ", font_black(" is higher than or equal to "), query, fixed = TRUE)
query <- gsub(" <= ", font_black(" is lower than or equal to "), query, fixed = TRUE)
query <- gsub(" ^ ", font_black(" to the power of "), query, fixed = TRUE)
query <- gsub(" %in% ", font_black(" is one of "), query, fixed = TRUE)
query <- gsub(" %like% ", font_black(" resembles "), query, fixed = TRUE)
if (colours == TRUE) {
query <- gsub('"R"', font_rsi_R_bg(font_black(" R ")), query, fixed = TRUE)
query <- gsub('"S"', font_rsi_S_bg(font_black(" S ")), query, fixed = TRUE)
query <- gsub('"I"', font_rsi_I_bg(font_black(" I ")), query, fixed = TRUE)
}
# replace the black colour 'stops' with blue colour 'starts'
query <- gsub("\033[39m", "\033[34m", as.character(query), fixed = TRUE)
# start with blue
query <- paste0("\033[34m", query)
if (colours == FALSE) {
query <- font_stripstyle(query)
}
query
}

407
R/eucast_rules.R
View File

@ -51,7 +51,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @inheritSection lifecycle Stable Lifecycle
#' @param x data with antibiotic columns, such as `amox`, `AMX` and `AMC`
#' @param info a logical to indicate whether progress should be printed to the console, defaults to only print while in interactive sessions
#' @param rules a character vector that specifies which rules should be applied. Must be one or more of `"breakpoints"`, `"expert"`, `"other"`, `"all"`, and defaults to `c("breakpoints", "expert")`. The default value can be set to another value, e.g. using `options(AMR_eucastrules = "all")`.
#' @param rules a character vector that specifies which rules should be applied. Must be one or more of `"breakpoints"`, `"expert"`, `"other"`, `"custom"`, `"all"`, and defaults to `c("breakpoints", "expert")`. The default value can be set to another value, e.g. using `options(AMR_eucastrules = "all")`. If using `"custom"`, be sure to fill in argument `custom_rules` too. Custom rules can be created with [custom_eucast_rules()].
#' @param verbose a [logical] to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. Using Verbose mode takes a lot more time.
#' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Can be either `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
#' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either `r vector_or(names(EUCAST_VERSION_EXPERT_RULES), reverse = TRUE)`.
@ -60,6 +60,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @param ab any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param administration route of administration, either `r vector_or(dosage$administration)`
#' @param only_rsi_columns a logical to indicate whether only antibiotic columns must be detected that were transformed to class `<rsi>` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param custom_rules custom rules to apply, created with [custom_eucast_rules()]
#' @inheritParams first_isolate
#' @details
#' **Note:** This function does not translate MIC values to RSI values. Use [as.rsi()] for that. \cr
@ -67,6 +68,18 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#'
#' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/master/data-raw/eucast_rules.tsv>.
#'
#' ## Custom Rules
#'
#' Custom rules can be created using [custom_eucast_rules()], e.g.:
#'
#' ```
#' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
#'
#' eucast_rules(example_isolates, rules = "custom", custom_rules = x)
#' ```
#'
#'
#' ## 'Other' Rules
#'
#' Before further processing, two non-EUCAST rules about drug combinations can be applied to improve the efficacy of the EUCAST rules, and the reliability of your data (analysis). These rules are:
@ -149,16 +162,31 @@ eucast_rules <- function(x,
version_expertrules = 3.2,
ampc_cephalosporin_resistance = NA,
only_rsi_columns = FALSE,
custom_rules = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4), is_in = c("breakpoints", "expert", "other", "all"))
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4, 5), is_in = c("breakpoints", "expert", "other", "all", "custom"))
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
meet_criteria(version_expertrules, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_EXPERT_RULES)))
meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "rsi"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
if ("custom" %in% rules & is.null(custom_rules)) {
warning_("No custom rules were set with the `custom_rules` argument",
call = FALSE,
immediate = TRUE)
rules <- rules[rules != "custom"]
if (length(rules) == 0) {
if (info == TRUE) {
message_("No other rules were set, returning original data", add_fn = font_red, as_note = FALSE)
}
return(x)
}
}
x_deparsed <- deparse(substitute(x))
if (length(x_deparsed) > 1 || !all(x_deparsed %like% "[a-z]+")) {
@ -263,238 +291,13 @@ eucast_rules <- function(x,
info = info,
only_rsi_columns = only_rsi_columns,
...)
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
AMX <- cols_ab["AMX"]
APL <- cols_ab["APL"]
APX <- cols_ab["APX"]
ATM <- cols_ab["ATM"]
AVB <- cols_ab["AVB"]
AVO <- cols_ab["AVO"]
AZD <- cols_ab["AZD"]
AZL <- cols_ab["AZL"]
AZM <- cols_ab["AZM"]
BAM <- cols_ab["BAM"]
BPR <- cols_ab["BPR"]
CAC <- cols_ab["CAC"]
CAT <- cols_ab["CAT"]
CAZ <- cols_ab["CAZ"]
CCP <- cols_ab["CCP"]
CCV <- cols_ab["CCV"]
CCX <- cols_ab["CCX"]
CDC <- cols_ab["CDC"]
CDR <- cols_ab["CDR"]
CDZ <- cols_ab["CDZ"]
CEC <- cols_ab["CEC"]
CED <- cols_ab["CED"]
CEI <- cols_ab["CEI"]
CEM <- cols_ab["CEM"]
CEP <- cols_ab["CEP"]
CFM <- cols_ab["CFM"]
CFM1 <- cols_ab["CFM1"]
CFP <- cols_ab["CFP"]
CFR <- cols_ab["CFR"]
CFS <- cols_ab["CFS"]
CFZ <- cols_ab["CFZ"]
CHE <- cols_ab["CHE"]
CHL <- cols_ab["CHL"]
CIC <- cols_ab["CIC"]
CID <- cols_ab["CID"]
CIP <- cols_ab["CIP"]
CLI <- cols_ab["CLI"]
CLM <- cols_ab["CLM"]
CLO <- cols_ab["CLO"]
CLR <- cols_ab["CLR"]
CMX <- cols_ab["CMX"]
CMZ <- cols_ab["CMZ"]
CND <- cols_ab["CND"]
COL <- cols_ab["COL"]
CPD <- cols_ab["CPD"]
CPI <- cols_ab["CPI"]
CPL <- cols_ab["CPL"]
CPM <- cols_ab["CPM"]
CPO <- cols_ab["CPO"]
CPR <- cols_ab["CPR"]
CPT <- cols_ab["CPT"]
CPX <- cols_ab["CPX"]
CRB <- cols_ab["CRB"]
CRD <- cols_ab["CRD"]
CRN <- cols_ab["CRN"]
CRO <- cols_ab["CRO"]
CSL <- cols_ab["CSL"]
CTB <- cols_ab["CTB"]
CTC <- cols_ab["CTC"]
CTF <- cols_ab["CTF"]
CTL <- cols_ab["CTL"]
CTS <- cols_ab["CTS"]
CTT <- cols_ab["CTT"]
CTX <- cols_ab["CTX"]
CTZ <- cols_ab["CTZ"]
CXM <- cols_ab["CXM"]
CYC <- cols_ab["CYC"]
CZA <- cols_ab["CZA"]
CZD <- cols_ab["CZD"]
CZO <- cols_ab["CZO"]
CZP <- cols_ab["CZP"]
CZX <- cols_ab["CZX"]
DAL <- cols_ab["DAL"]
DAP <- cols_ab["DAP"]
DIC <- cols_ab["DIC"]
DIR <- cols_ab["DIR"]
DIT <- cols_ab["DIT"]
DIX <- cols_ab["DIX"]
DIZ <- cols_ab["DIZ"]
DKB <- cols_ab["DKB"]
DOR <- cols_ab["DOR"]
DOX <- cols_ab["DOX"]
ENX <- cols_ab["ENX"]
EPC <- cols_ab["EPC"]
ERY <- cols_ab["ERY"]
ETP <- cols_ab["ETP"]
FEP <- cols_ab["FEP"]
FLC <- cols_ab["FLC"]
FLE <- cols_ab["FLE"]
FLR1 <- cols_ab["FLR1"]
FOS <- cols_ab["FOS"]
FOV <- cols_ab["FOV"]
FOX <- cols_ab["FOX"]
FOX1 <- cols_ab["FOX1"]
FUS <- cols_ab["FUS"]
GAT <- cols_ab["GAT"]
GEM <- cols_ab["GEM"]
GEN <- cols_ab["GEN"]
GRX <- cols_ab["GRX"]
HAP <- cols_ab["HAP"]
HET <- cols_ab["HET"]
IPM <- cols_ab["IPM"]
ISE <- cols_ab["ISE"]
JOS <- cols_ab["JOS"]
KAN <- cols_ab["KAN"]
LEN <- cols_ab["LEN"]
LEX <- cols_ab["LEX"]
LIN <- cols_ab["LIN"]
LNZ <- cols_ab["LNZ"]
LOM <- cols_ab["LOM"]
LOR <- cols_ab["LOR"]
LTM <- cols_ab["LTM"]
LVX <- cols_ab["LVX"]
MAN <- cols_ab["MAN"]
MCM <- cols_ab["MCM"]
MEC <- cols_ab["MEC"]
MEM <- cols_ab["MEM"]
MET <- cols_ab["MET"]
MEV <- cols_ab["MEV"]
MEZ <- cols_ab["MEZ"]
MFX <- cols_ab["MFX"]
MID <- cols_ab["MID"]
MNO <- cols_ab["MNO"]
MTM <- cols_ab["MTM"]
NAC <- cols_ab["NAC"]
NAF <- cols_ab["NAF"]
NAL <- cols_ab["NAL"]
NEO <- cols_ab["NEO"]
NET <- cols_ab["NET"]
NIT <- cols_ab["NIT"]
NOR <- cols_ab["NOR"]
NOV <- cols_ab["NOV"]
NVA <- cols_ab["NVA"]
OFX <- cols_ab["OFX"]
OLE <- cols_ab["OLE"]
ORI <- cols_ab["ORI"]
OXA <- cols_ab["OXA"]
PAZ <- cols_ab["PAZ"]
PEF <- cols_ab["PEF"]
PEN <- cols_ab["PEN"]
PHE <- cols_ab["PHE"]
PHN <- cols_ab["PHN"]
PIP <- cols_ab["PIP"]
PLB <- cols_ab["PLB"]
PME <- cols_ab["PME"]
PNM <- cols_ab["PNM"]
PRC <- cols_ab["PRC"]
PRI <- cols_ab["PRI"]
PRL <- cols_ab["PRL"]
PRP <- cols_ab["PRP"]
PRU <- cols_ab["PRU"]
PVM <- cols_ab["PVM"]
QDA <- cols_ab["QDA"]
RAM <- cols_ab["RAM"]
RFL <- cols_ab["RFL"]
RID <- cols_ab["RID"]
RIF <- cols_ab["RIF"]
ROK <- cols_ab["ROK"]
RST <- cols_ab["RST"]
RXT <- cols_ab["RXT"]
SAM <- cols_ab["SAM"]
SBC <- cols_ab["SBC"]
SDI <- cols_ab["SDI"]
SDM <- cols_ab["SDM"]
SIS <- cols_ab["SIS"]
SLF <- cols_ab["SLF"]
SLF1 <- cols_ab["SLF1"]
SLF10 <- cols_ab["SLF10"]
SLF11 <- cols_ab["SLF11"]
SLF12 <- cols_ab["SLF12"]
SLF13 <- cols_ab["SLF13"]
SLF2 <- cols_ab["SLF2"]
SLF3 <- cols_ab["SLF3"]
SLF4 <- cols_ab["SLF4"]
SLF5 <- cols_ab["SLF5"]
SLF6 <- cols_ab["SLF6"]
SLF7 <- cols_ab["SLF7"]
SLF8 <- cols_ab["SLF8"]
SLF9 <- cols_ab["SLF9"]
SLT1 <- cols_ab["SLT1"]
SLT2 <- cols_ab["SLT2"]
SLT3 <- cols_ab["SLT3"]
SLT4 <- cols_ab["SLT4"]
SLT5 <- cols_ab["SLT5"]
SLT6 <- cols_ab["SLT6"]
SMX <- cols_ab["SMX"]
SPI <- cols_ab["SPI"]
SPX <- cols_ab["SPX"]
SRX <- cols_ab["SRX"]
STR <- cols_ab["STR"]
STR1 <- cols_ab["STR1"]
SUD <- cols_ab["SUD"]
SUL <- cols_ab["SUL"]
SUT <- cols_ab["SUT"]
SXT <- cols_ab["SXT"]
SZO <- cols_ab["SZO"]
TAL <- cols_ab["TAL"]
TAZ <- cols_ab["TAZ"]
TCC <- cols_ab["TCC"]
TCM <- cols_ab["TCM"]
TCY <- cols_ab["TCY"]
TEC <- cols_ab["TEC"]
TEM <- cols_ab["TEM"]
TGC <- cols_ab["TGC"]
THA <- cols_ab["THA"]
TIC <- cols_ab["TIC"]
TIO <- cols_ab["TIO"]
TLT <- cols_ab["TLT"]
TLV <- cols_ab["TLV"]
TMP <- cols_ab["TMP"]
TMX <- cols_ab["TMX"]
TOB <- cols_ab["TOB"]
TRL <- cols_ab["TRL"]
TVA <- cols_ab["TVA"]
TZD <- cols_ab["TZD"]
TZP <- cols_ab["TZP"]
VAN <- cols_ab["VAN"]
ab_missing <- function(ab) {
all(ab %in% c(NULL, NA))
}
if (ab_missing(AMP) & !ab_missing(AMX)) {
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available
if (info == TRUE) {
message_("Using column '", font_bold(AMX), "' as input for ampicillin since many EUCAST rules depend on it.")
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many EUCAST rules depend on it.")
}
AMP <- AMX
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
}
# data preparation ----
@ -502,40 +305,23 @@ eucast_rules <- function(x,
message_("Preparing data...", appendLF = FALSE, as_note = FALSE)
}
# nolint start
# antibiotic classes ----
aminoglycosides <- c(AMK, DKB, GEN, ISE, KAN, NEO, NET, RST, SIS, STR, STR1, TOB)
aminopenicillins <- c(AMP, AMX)
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
cephalosporins <- c(CDZ, CCP, CAC, CEC, CFR, RID, MAN, CTZ, CZD, CZO, CDR, DIT, FEP, CAT, CFM, CMX, CMZ, DIZ, CID, CFP, CSL, CND, CTX, CTT, CTF, FOX, CPM, CPO, CPD, CPR, CRD, CFS, CPT, CAZ, CCV, CTL, CTB, CZX, BPR, CFM1, CEI, CRO, CXM, LEX, CEP, HAP, CED, LTM, LOR)
cephalosporins_1st <- c(CAC, CFR, RID, CTZ, CZD, CZO, CRD, CTL, LEX, CEP, HAP, CED)
cephalosporins_2nd <- c(CEC, MAN, CMZ, CID, CND, CTT, CTF, FOX, CPR, CXM, LOR)
cephalosporins_3rd <- c(CDZ, CCP, CCX, CDR, DIT, DIX, CAT, CPI, CFM, CMX, DIZ, CFP, CSL, CTX, CTC, CTS, CHE, FOV, CFZ, CPM, CPD, CPX, CDC, CFS, CAZ, CZA, CCV, CEM, CPL, CTB, TIO, CZX, CZP, CRO, LTM)
cephalosporins_except_CAZ <- cephalosporins[cephalosporins != ifelse(is.null(CAZ), "", CAZ)]
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
glycopeptides <- c(AVO, NVA, RAM, TEC, TCM, VAN) # dalba/orita/tela are in lipoglycopeptides
lincosamides <- c(CLI, LIN, PRL)
lipoglycopeptides <- c(DAL, ORI, TLV)
macrolides <- c(AZM, CLR, DIR, ERY, FLR1, JOS, MID, MCM, OLE, ROK, RXT, SPI, TLT, TRL)
oxazolidinones <- c(CYC, LNZ, THA, TZD)
polymyxins <- c(PLB, COL)
streptogramins <- c(QDA, PRI)
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
ureidopenicillins <- c(PIP, TZP, AZL, MEZ)
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
# nolint end
# Some helper functions ---------------------------------------------------
get_antibiotic_columns <- function(x, df) {
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
y <- character(0)
for (i in seq_len(length(x))) {
if (is.function(get(x[i]))) {
stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.")
get_antibiotic_columns <- function(x, cols_ab) {
x <- strsplit(x, ", *")[[1]]
x_new <- character()
for (val in x) {
if (toupper(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) {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {
stop_("antimicrobial agent (group) not found in EUCAST rules file: ", val, call = FALSE)
}
y <- c(y, tryCatch(get(x[i]), error = function(e) ""))
x_new <- c(x_new, val)
}
y[y != "" & y %in% colnames(df)]
cols_ab[match(x_new, names(cols_ab))]
}
markup_italics_where_needed <- function(x) {
# returns names found in family, genus or species as italics
@ -688,7 +474,8 @@ eucast_rules <- function(x,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info)
info = info,
verbose = verbose)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@ -720,7 +507,8 @@ eucast_rules <- function(x,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info)
info = info,
verbose = verbose)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@ -740,10 +528,17 @@ eucast_rules <- function(x,
} else {
if (info == TRUE) {
cat("\n")
message_("Skipping inheritance rules defined by this package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R. Use `eucast_rules(..., rules = \"all\")` to also apply those rules.")
message_("Skipping inheritance rules defined by this AMR package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R. Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
}
}
if (!any(c("all", "custom") %in% rules) & !is.null(custom_rules)) {
if (info == TRUE) {
message_("Skipping custom EUCAST rules, since the `rules` argument does not contain \"custom\".")
}
custom_rules <- NULL
}
# Official EUCAST rules ---------------------------------------------------
eucast_notification_shown <- FALSE
if (!is.null(list(...)$eucast_rules_df)) {
@ -777,6 +572,7 @@ eucast_rules <- function(x,
eucast_rules_df[which(eucast_rules_df$reference.rule %like% "ampc"), "to_value"] <- as.character(ampc_cephalosporin_resistance)
}
# Go over all rules and apply them ----
for (i in seq_len(nrow(eucast_rules_df))) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule", drop = TRUE]
@ -899,26 +695,26 @@ eucast_rules <- function(x,
source_value <- trimws(unlist(strsplit(eucast_rules_df[i, "have_these_values", drop = TRUE], ",", fixed = TRUE)))
target_antibiotics <- eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE]
target_value <- eucast_rules_df[i, "to_value", drop = TRUE]
if (is.na(source_antibiotics)) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value),
error = function(e) integer(0))
} else {
source_antibiotics <- get_antibiotic_columns(source_antibiotics, x)
source_antibiotics <- get_antibiotic_columns(source_antibiotics, cols_ab)
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
source_value <- rep(source_value, length(source_antibiotics))
}
if (length(source_antibiotics) == 0) {
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0))
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0))
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0))
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
& as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
& as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0))
# nolint start
# } else if (length(source_antibiotics) == 3) {
# rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
@ -932,7 +728,7 @@ eucast_rules <- function(x,
}
}
cols <- get_antibiotic_columns(target_antibiotics, x)
cols <- get_antibiotic_columns(target_antibiotics, cols_ab)
# Apply rule on data ------------------------------------------------------
# this will return the unique number of changes
@ -948,7 +744,8 @@ eucast_rules <- function(x,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info)
info = info,
verbose = verbose)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
@ -962,6 +759,61 @@ eucast_rules <- function(x,
n_added <- 0
n_changed <- 0
}
} # end of going over all rules
# Apply custom rules ----
if (!is.null(custom_rules)) {
if (info == TRUE) {
cat("\n")
cat(font_bold("Custom EUCAST rules, set by user"), "\n")
}
for (i in seq_len(length(custom_rules))) {
rule <- custom_rules[[i]]
rows <- which(eval(parse(text = rule$query), envir = x))
cols <- as.character(rule$result_group)
cols <- c(cols[cols %in% colnames(x)], # direct column names
unname(cols_ab[names(cols_ab) %in% cols])) # based on previous cols_ab finding
cols <- unique(cols)
target_value <- as.character(rule$result_value)
rule_text <- paste0("report as '", target_value, "' when ",
format_custom_query_rule(rule$query, colours = FALSE), ": ",
get_antibiotic_names(cols))
if (info == TRUE) {
# print rule
cat(markup_italics_where_needed(word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
width = getOption("width") - 30,
extra_indent = 6)))
warned <- FALSE
}
run_changes <- edit_rsi(x = x,
col_mo = col_mo,
to = target_value,
rule = c(rule_text,
"Custom EUCAST rules",
paste0("Custom EUCAST rule ", i),
paste0("Object '", deparse(substitute(custom_rules)),
"' consisting of ", length(custom_rules), " custom rules")),
rows = rows,
cols = cols,
last_verbose_info = verbose_info,
original_data = x.bak,
warned = warned,
info = info,
verbose = verbose)
n_added <- n_added + run_changes$added
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
x <- run_changes$output
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
# Print number of new changes ---------------------------------------------
if (info == TRUE & rule_next != rule_current) {
# print only on last one of rules in this group
txt_ok(n_added = n_added, n_changed = n_changed, warned = warned)
# and reset counters
n_added <- 0
n_changed <- 0
}
}
}
# Print overview ----------------------------------------------------------
@ -1089,7 +941,8 @@ edit_rsi <- function(x,
last_verbose_info,
original_data,
warned,
info) {
info,
verbose) {
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
# for Verbose Mode, keep track of all changes and return them
@ -1146,7 +999,7 @@ edit_rsi <- function(x,
)
track_changes$output <- new_edits
if (isTRUE(info) && !isTRUE(all.equal(x, track_changes$output))) {
if ((info == TRUE | verbose == TRUE) && !isTRUE(all.equal(x, track_changes$output))) {
get_original_rows <- function(rowids) {
as.integer(rownames(original_data[which(original_data$.rowid %in% rowids), , drop = FALSE]))
}

25
R/like.R
View File

@ -23,14 +23,14 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Pattern Matching with Keyboard Shortcut
#' Vectorised Pattern Matching with Keyboard Shortcut
#'
#' Convenient wrapper around [grepl()] to match a pattern: `x %like% pattern`. It always returns a [`logical`] vector and is always case-insensitive (use `x %like_case% pattern` for case-sensitive matching). Also, `pattern` can be as long as `x` to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a character vector where matches are sought, or an object which can be coerced by [as.character()] to a character vector.
#' @param pattern a character string containing a regular expression (or [character] string for `fixed = TRUE`) to be matched in the given character vector. Coerced by [as.character()] to a character string if possible. If a [character] vector of length 2 or more is supplied, the first element is used with a warning.
#' @param ignore.case if `FALSE`, the pattern matching is *case sensitive* and if `TRUE`, case is ignored during matching.
#' @return A [`logical`] vector
#' @return A [logical] vector
#' @name like
#' @rdname like
#' @export
@ -39,10 +39,10 @@
#' * Is case-insensitive (use `%like_case%` for case-sensitive matching)
#' * Supports multiple patterns
#' * Checks if `pattern` is a regular expression and sets `fixed = TRUE` if not, to greatly improve speed
#' * Always uses compatibility with Perl
#' * Always uses compatibility with Perl unless `fixed = TRUE`, to greatly improve speed
#'
#' Using RStudio? The text `%like%` can also be directly inserted in your code from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`).
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R)
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/ec1259af1bf13fc0c96a1d3f9e84d55d8106a9a4/R/like.R)
#' @seealso [grepl()]
#' @inheritSection AMR Read more on Our Website!
#' @examples
@ -68,7 +68,7 @@
#' \donttest{
#' if (require("dplyr")) {
#' example_isolates %>%
#' filter(mo_name(mo) %like% "^ent")
#' filter(mo_name() %like% "^ent")
#' }
#' }
like <- function(x, pattern, ignore.case = TRUE) {
@ -98,14 +98,17 @@ like <- function(x, pattern, ignore.case = TRUE) {
if (length(x) == 1) {
x <- rep(x, length(pattern))
} else if (length(pattern) != length(x)) {
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1")
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1 ",
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")")
}
unlist(
Map(f = grepl,
pattern,
x,
MoreArgs = list(ignore.case = FALSE, fixed = fixed, perl = !fixed)),
use.names = FALSE)
mapply(FUN = grepl,
x = x,
pattern = pattern,
MoreArgs = list(ignore.case = FALSE, fixed = fixed, perl = !fixed),
SIMPLIFY = FALSE,
USE.NAMES = FALSE)
)
}
}

99
R/mdro.R
View File

@ -102,10 +102,22 @@
#' The outcome of the function can be used for the `guideline` argument in the [mdro()] function:
#'
#' ```
#' x <- mdro(example_isolates, guideline = custom)
#' x <- mdro(example_isolates,
#' guideline = custom)
#' table(x)
#' #> Elderly Type A Elderly Type B Negative
#' #> 43 891 1066
#' #> Negative Elderly Type A Elderly Type B
#' #> 1070 198 732
#' ```
#'
#' Rules can also be combined with other custom rules by using [c()]:
#'
#' ```
#' x <- mdro(example_isolates,
#' guideline = c(custom,
#' custom_mdro_guideline(ERY == "R" & age > 50 ~ "Elderly Type C")))
#' table(x)
#' #> Negative Elderly Type A Elderly Type B Elderly Type C
#' #> 961 198 732 109
#' ```
#'
#' The rules set (the `custom` object in this case) could be exported to a shared file location using [saveRDS()] if you collaborate with multiple users. The custom rules set could then be imported using [readRDS()].
@ -246,7 +258,7 @@ mdro <- function(x = NULL,
txt <- word_wrap(txt)
cat(txt, "\n", sep = "")
}
x <- run_custom_mdro_guideline(x, guideline)
x <- run_custom_mdro_guideline(df = x, guideline = guideline, info = info)
if (info.bak == TRUE) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
@ -1434,6 +1446,8 @@ mdro <- function(x = NULL,
#' @rdname mdro
#' @export
custom_mdro_guideline <- function(..., as_factor = TRUE) {
meet_criteria(as_factor, allow_class = "logical", has_length = 1)
dots <- tryCatch(list(...),
error = function(e) "error")
stop_if(identical(dots, "error"),
@ -1470,11 +1484,49 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
names(out) <- paste0("rule", seq_len(n_dots))
out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list"))
attr(out, "values") <- c("Negative", vapply(FUN.VALUE = character(1), out, function(x) x$value))
attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value)))
attr(out, "as_factor") <- as_factor
out
}
#' @method c custom_mdro_guideline
#' @noRd
#' @export
c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
if (length(list(...)) == 0) {
return(x)
}
if (!is.null(as_factor)) {
meet_criteria(as_factor, allow_class = "logical", has_length = 1)
} else {
as_factor <- attributes(x)$as_factor
}
for (g in list(...)) {
stop_ifnot(inherits(g, "custom_mdro_guideline"),
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
call = FALSE)
vals <- attributes(x)$values
if (!all(attributes(g)$values %in% vals)) {
vals <- unname(unique(c(vals, attributes(g)$values)))
}
attributes(g) <- NULL
x <- c(unclass(x), unclass(g))
attr(x, "values") <- vals
}
names(x) <- paste0("rule", seq_len(length(x)))
x <- set_clean_class(x, new_class = c("custom_mdro_guideline", "list"))
attr(x, "values") <- vals
attr(x, "as_factor") <- as_factor
x
}
#' @method as.list custom_mdro_guideline
#' @noRd
#' @export
as.list.custom_mdro_guideline <- function(x, ...) {
c(x, ...)
}
#' @method print custom_mdro_guideline
#' @export
#' @noRd
@ -1482,23 +1534,10 @@ print.custom_mdro_guideline <- function(x, ...) {
cat("A set of custom MDRO rules:\n")
for (i in seq_len(length(x))) {
rule <- x[[i]]
rule$query <- gsub(" & ", font_black(font_italic(" and ")), rule$query, fixed = TRUE)
rule$query <- gsub(" | ", font_black(" or "), rule$query, fixed = TRUE)
rule$query <- gsub(" + ", font_black(" plus "), rule$query, fixed = TRUE)
rule$query <- gsub(" - ", font_black(" minus "), rule$query, fixed = TRUE)
rule$query <- gsub(" / ", font_black(" divided by "), rule$query, fixed = TRUE)
rule$query <- gsub(" * ", font_black(" times "), rule$query, fixed = TRUE)
rule$query <- gsub(" == ", font_black(" is "), rule$query, fixed = TRUE)
rule$query <- gsub(" > ", font_black(" is higher than "), rule$query, fixed = TRUE)
rule$query <- gsub(" < ", font_black(" is lower than "), rule$query, fixed = TRUE)
rule$query <- gsub(" >= ", font_black(" is higher than or equal to "), rule$query, fixed = TRUE)
rule$query <- gsub(" <= ", font_black(" is lower than or equal to "), rule$query, fixed = TRUE)
rule$query <- gsub(" ^ ", font_black(" to the power of "), rule$query, fixed = TRUE)
# replace the black colour 'stops' with blue colour 'starts'
rule$query <- gsub("\033[39m", "\033[34m", as.character(rule$query), fixed = TRUE)
cat(" ", i, ". ", font_blue(rule$query), font_bold(" -> "), font_red(rule$value), "\n", sep = "")
rule$query <- format_custom_query_rule(rule$query)
cat(" ", i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then: "), font_red(rule$value), "\n", sep = "")
}
cat(" ", i + 1, ". Otherwise", font_bold(" -> "), font_red(paste0("Negative")), "\n", sep = "")
cat(" ", i + 1, ". ", font_bold("Otherwise: "), font_red(paste0("Negative")), "\n", sep = "")
cat("\nUnmatched rows will return ", font_red("NA"), ".\n", sep = "")
if (isTRUE(attributes(x)$as_factor)) {
cat("Results will be of class <factor>, with ordered levels: ", paste0(attributes(x)$values, collapse = " < "), "\n", sep = "")
@ -1507,7 +1546,7 @@ print.custom_mdro_guideline <- function(x, ...) {
}
}
run_custom_mdro_guideline <- function(df, guideline) {
run_custom_mdro_guideline <- function(df, guideline, info) {
n_dots <- length(guideline)
stop_if(n_dots == 0, "no custom guidelines set", call = -2)
out <- character(length = NROW(df))
@ -1520,7 +1559,7 @@ run_custom_mdro_guideline <- function(df, guideline) {
})
if (identical(qry, "error")) {
warning_("in custom_mdro_guideline(): rule ", i,
" (`", guideline[[i]]$query, "`) was ignored because of this error message: ",
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
pkg_env$err_msg,
call = FALSE,
add_fn = font_red)
@ -1529,9 +1568,16 @@ run_custom_mdro_guideline <- function(df, guideline) {
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE), call = FALSE)
new_mdros <- which(qry == TRUE & out == "")
if (info == TRUE) {
cat(word_wrap("- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
"` (", length(new_mdros), " rows matched)"), "\n", sep = "")
}
val <- guideline[[i]]$value
out[which(qry)] <- val
reasons[which(qry)] <- paste0("matched rule ", gsub("rule", "", names(guideline)[i]), ": ", as.character(guideline[[i]]$query))
out[new_mdros] <- val
reasons[new_mdros] <- paste0("matched rule ", gsub("rule", "", names(guideline)[i]), ": ", as.character(guideline[[i]]$query))
}
out[out == ""] <- "Negative"
reasons[out == "Negative"] <- "no rules matched"
@ -1540,8 +1586,7 @@ run_custom_mdro_guideline <- function(df, guideline) {
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
}
rsi_cols <- vapply(FUN.VALUE = logical(1), df, function(x) is.rsi(x))
columns_nonsusceptible <- as.data.frame(t(df[, rsi_cols] == "R"))
columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df)] == "R"))
columns_nonsusceptible <- vapply(FUN.VALUE = character(1),
columns_nonsusceptible,
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " "))

44
R/mo.R
View File

@ -1654,10 +1654,28 @@ pillar_shaft.mo <- function(x, ...) {
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
# and grey out every _
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
# markup NA and UNKNOWN
out[is.na(x)] <- font_na(" NA")
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) {
# markup old mo codes
out[!x %in% MO_lookup$mo] <- font_italic(font_na(x[!x %in% MO_lookup$mo],
collapse = NULL),
collapse = NULL)
# throw a warning with the affected column name
mo <- tryCatch(search_type_in_df(get_current_data(arg_name = "x", call = 0), type = "mo", info = FALSE),
error = function(e) NULL)
if (!is.null(mo)) {
col <- paste0("Column '", mo, "'")
} else {
col <- "The data"
}
warning_(col, " contains old microbial codes (from a previous AMR package version). ",
"Please update your MO codes with `as.mo()`.",
call = FALSE)
}
# make it always fit exactly
max_char <- max(nchar(x))
@ -1753,11 +1771,16 @@ summary.mo <- function(object, ...) {
#' @export
#' @noRd
as.data.frame.mo <- function(x, ...) {
if (!all(x[!is.na(x)] %in% MO_lookup$mo)) {
warning_("The data contains old microbial codes (from a previous AMR package version). ",
"Please update your MO codes with `as.mo()`.",
call = FALSE)
}
nm <- deparse1(substitute(x))
if (!"nm" %in% names(list(...))) {
as.data.frame.vector(as.mo(x), ..., nm = nm)
as.data.frame.vector(x, ..., nm = nm)
} else {
as.data.frame.vector(as.mo(x), ...)
as.data.frame.vector(x, ...)
}
}
@ -1875,6 +1898,7 @@ print.mo_uncertainties <- function(x, ...) {
collapse = "")
# after strwrap, make taxonomic names italic
candidates <- gsub("([A-Za-z]+)", font_italic("\\1"), candidates, perl = TRUE)
candidates <- gsub(font_italic("and"), "and", candidates, fixed = TRUE)
candidates <- gsub(paste(font_italic(c("Also", "matched"), collapse = NULL), collapse = " "),
"Also matched",
candidates, fixed = TRUE)