mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 14:01:55 +02:00
(v1.7.1.9064) eucast 3.3 for mdro(), major change to repeated calling
This commit is contained in:
@ -201,7 +201,7 @@ check_dataset_integrity <- function() {
|
||||
} else {
|
||||
plural <- c(" is", "s", "")
|
||||
}
|
||||
if (message_not_thrown_before("dataset_overwritten")) {
|
||||
if (message_not_thrown_before("check_dataset_integrity", overwritten)) {
|
||||
warning_("The following data set", plural[1],
|
||||
" overwritten by your global environment and prevent", plural[2],
|
||||
" the AMR package from working correctly: ",
|
||||
@ -323,7 +323,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
found <- found[1]
|
||||
|
||||
if (!is.null(found) & info == TRUE) {
|
||||
if (message_not_thrown_before(fn = paste0("search_", type))) {
|
||||
if (message_not_thrown_before("search_in_type", type)) {
|
||||
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
|
||||
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
|
||||
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
@ -804,14 +804,17 @@ meet_criteria <- function(object,
|
||||
}
|
||||
|
||||
get_current_data <- function(arg_name, call) {
|
||||
valid_df <- function(x) {
|
||||
!is.null(x) && is.data.frame(x)
|
||||
}
|
||||
# try dplyr::cur_data_all() first to support dplyr groups
|
||||
# only useful for e.g. dplyr::filter(), dplyr::mutate() and dplyr::summarise()
|
||||
# not useful (throws error) with e.g. dplyr::select() - but that will be caught later in this function
|
||||
cur_data_all <- import_fn("cur_data_all", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_data_all)) {
|
||||
out <- tryCatch(cur_data_all(), error = function(e) NULL)
|
||||
if (is.data.frame(out)) {
|
||||
return(structure(out, type = "dplyr_cur_data_all"))
|
||||
if (valid_df(out)) {
|
||||
return(out)
|
||||
}
|
||||
}
|
||||
|
||||
@ -820,18 +823,18 @@ get_current_data <- function(arg_name, call) {
|
||||
if (!is.null(env$`.Generic`)) {
|
||||
# don't check `".Generic" %in% names(env)`, because in R < 3.2, `names(env)` is always NULL
|
||||
|
||||
if (!is.null(env$`.data`) && is.data.frame(env$`.data`)) {
|
||||
if (valid_df(env$`.data`)) {
|
||||
# an element `.data` will be in the environment when using `dplyr::select()`
|
||||
# (but not when using `dplyr::filter()`, `dplyr::mutate()` or `dplyr::summarise()`)
|
||||
return(structure(env$`.data`, type = "dplyr_selector"))
|
||||
return(env$`.data`)
|
||||
|
||||
} else if (!is.null(env$xx) && is.data.frame(env$xx)) {
|
||||
} else if (valid_df(env$xx)) {
|
||||
# an element `xx` will be in the environment for rows + cols, e.g. `example_isolates[c(1:3), carbapenems()]`
|
||||
return(structure(env$xx, type = "base_R"))
|
||||
return(env$xx)
|
||||
|
||||
} else if (!is.null(env$x) && is.data.frame(env$x)) {
|
||||
} else if (valid_df(env$x)) {
|
||||
# an element `x` will be in the environment for only cols, e.g. `example_isolates[, carbapenems()]`
|
||||
return(structure(env$x, type = "base_R"))
|
||||
return(env$x)
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -901,32 +904,43 @@ is_null_or_grouped_tbl <- function(x) {
|
||||
is.null(x) || inherits(x, "grouped_df")
|
||||
}
|
||||
|
||||
unique_call_id <- function(entire_session = FALSE) {
|
||||
unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
|
||||
if (entire_session == TRUE) {
|
||||
c(envir = "session",
|
||||
call = "session")
|
||||
} else {
|
||||
# combination of environment ID (such as "0x7fed4ee8c848")
|
||||
# and highest system call
|
||||
call <- paste0(deparse(sys.calls()[[1]]), collapse = "")
|
||||
if (!interactive() || call %like% "run_test_dir|test_all|tinytest|test_package|testthat") {
|
||||
# unit tests will keep the same call and environment - give them a unique ID
|
||||
call <- paste0(sample(c(c(0:9), letters[1:6]), size = 64, replace = TRUE), collapse = "")
|
||||
}
|
||||
c(envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]])),
|
||||
call = call)
|
||||
return(c(envir = "session", call = "session"))
|
||||
}
|
||||
|
||||
# combination of environment ID (such as "0x7fed4ee8c848")
|
||||
# and relevant system call (where 'match_fn' is being called in)
|
||||
calls <- sys.calls()
|
||||
int <- which(vapply(FUN.VALUE = logical(1),
|
||||
calls,
|
||||
function(call, fun = match_fn) {
|
||||
call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(call), perl = TRUE)
|
||||
any(call_clean %like% paste0(fun, "\\("), na.rm = TRUE)
|
||||
}))[1L]
|
||||
if (is.na(int)) {
|
||||
int <- 1
|
||||
}
|
||||
c(envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE),
|
||||
call = paste0(deparse(calls[[int]]), collapse = ""))
|
||||
}
|
||||
|
||||
message_not_thrown_before <- function(fn, entire_session = FALSE) {
|
||||
#' @noRd
|
||||
#' @param fn name of the function as a character
|
||||
#' @param ... character elements to be pasted together as a 'salt'
|
||||
#' @param entire_session show message once per session
|
||||
message_not_thrown_before <- function(fn, ..., entire_session = FALSE) {
|
||||
# this is to prevent that messages/notes will be printed for every dplyr group or more than once per session
|
||||
# e.g. this would show a msg 4 times: example_isolates %>% group_by(hospital_id) %>% filter(mo_is_gram_negative())
|
||||
not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]],
|
||||
unique_call_id(entire_session = entire_session))
|
||||
salt <- gsub("[^a-zA-Z0-9|_-]", "?", paste(c(...), sep = "|", collapse = "|"), perl = TRUE)
|
||||
not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]]) ||
|
||||
!identical(pkg_env[[paste0("thrown_msg.", fn, ".", salt)]],
|
||||
unique_call_id(entire_session = entire_session,
|
||||
match_fn = fn))
|
||||
if (isTRUE(not_thrown_before)) {
|
||||
# message was not thrown before - remember this so on the next run it will return FALSE:
|
||||
assign(x = paste0("thrown_msg.", fn),
|
||||
value = unique_call_id(entire_session = entire_session),
|
||||
assign(x = paste0("thrown_msg.", fn, ".", salt),
|
||||
value = unique_call_id(entire_session = entire_session, match_fn = fn),
|
||||
envir = pkg_env)
|
||||
}
|
||||
not_thrown_before
|
||||
|
||||
@ -33,7 +33,7 @@
|
||||
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
|
||||
#' @param administration way of administration, either `"oral"` or `"iv"`
|
||||
#' @param open browse the URL using [utils::browseURL()]
|
||||
#' @param ... in case of [set_ab_names()] and `data` is a [data.frame]: variables to select (supports tidy selection like `AMX:VAN`), otherwise other arguments passed on to [as.ab()]
|
||||
#' @param ... in case of [set_ab_names()] and `data` is a [data.frame]: variables to select (supports tidy selection such as `column1:column4`), otherwise other arguments passed on to [as.ab()]
|
||||
#' @param data a [data.frame] of which the columns need to be renamed, or a [character] vector of column names
|
||||
#' @param snake_case a [logical] to indicate whether the names should be in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`)
|
||||
#' @param only_first a [logical] to indicate whether only the first ATC code must be returned, with giving preference to J0-codes (i.e., the antimicrobial drug group)
|
||||
@ -359,7 +359,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_locale(),
|
||||
} else {
|
||||
df <- data
|
||||
}
|
||||
vars <- get_column_abx(df, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
|
||||
vars <- get_column_abx(df, info = FALSE, only_rsi_columns = FALSE, sort = FALSE, fn = "set_ab_names")
|
||||
if (length(vars) == 0) {
|
||||
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
|
||||
return(data)
|
||||
|
||||
@ -181,7 +181,8 @@ ab_selector <- function(filter,
|
||||
# but it only takes a couple of milliseconds
|
||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
|
||||
sort = FALSE, fn = "ab_selector")
|
||||
call <- substitute(filter)
|
||||
agents <- tryCatch(AMR::antibiotics[which(eval(call, envir = AMR::antibiotics)), "ab", drop = TRUE],
|
||||
error = function(e) stop_(e$message, call = -5))
|
||||
@ -383,7 +384,8 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
|
||||
# but it only takes a couple of milliseconds
|
||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
|
||||
sort = FALSE, fn = "administrable_per_os")
|
||||
agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
|
||||
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
|
||||
agents <- ab_in_data[ab_in_data %in% agents]
|
||||
@ -410,7 +412,8 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
|
||||
# but it only takes a couple of milliseconds
|
||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
|
||||
sort = FALSE, fn = "administrable_iv")
|
||||
agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
|
||||
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
|
||||
agents <- ab_in_data[ab_in_data %in% agents]
|
||||
@ -432,7 +435,8 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
|
||||
# but it only takes a couple of milliseconds
|
||||
vars_df <- get_current_data(arg_name = NA, call = -2)
|
||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
|
||||
sort = FALSE, fn = "not_intrinsic_resistant")
|
||||
# intrinsic vars
|
||||
vars_df_R <- tryCatch(sapply(eucast_rules(vars_df,
|
||||
col_mo = col_mo,
|
||||
@ -445,7 +449,7 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
|
||||
|
||||
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
||||
if (length(agents) > 0 &&
|
||||
message_not_thrown_before(paste0("not_intrinsic_resistant.", paste(sort(agents), collapse = "|")))) {
|
||||
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
|
||||
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
||||
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
||||
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
||||
@ -470,21 +474,24 @@ ab_select_exec <- function(function_name,
|
||||
# but it only takes a couple of milliseconds
|
||||
vars_df <- get_current_data(arg_name = NA, call = -3)
|
||||
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns, sort = FALSE)
|
||||
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
|
||||
sort = FALSE, fn = function_name)
|
||||
# untreatable drugs
|
||||
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate"), "ab", drop = TRUE]
|
||||
if (only_treatable == TRUE & any(untreatable %in% names(ab_in_data))) {
|
||||
if (message_not_thrown_before(paste0("ab_class.untreatable.", function_name), entire_session = TRUE)) {
|
||||
warning_("Some agents in `", function_name, "()` were ignored since they cannot be used for treating patients: ",
|
||||
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||
language = NULL,
|
||||
tolower = TRUE),
|
||||
quotes = FALSE,
|
||||
sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
|
||||
"This warning will be shown once per session.",
|
||||
call = FALSE)
|
||||
if (only_treatable == TRUE) {
|
||||
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening"), "ab", drop = TRUE]
|
||||
if (any(untreatable %in% names(ab_in_data))) {
|
||||
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
|
||||
warning_("Some agents in `", function_name, "()` were ignored since they cannot be used for treating patients: ",
|
||||
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||
language = NULL,
|
||||
tolower = TRUE),
|
||||
quotes = FALSE,
|
||||
sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
|
||||
"This warning will be shown once per session.",
|
||||
call = FALSE)
|
||||
}
|
||||
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
|
||||
}
|
||||
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
|
||||
}
|
||||
|
||||
if (length(ab_in_data) == 0) {
|
||||
@ -666,14 +673,14 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
}
|
||||
|
||||
is_any <- function(el1) {
|
||||
syscall <- paste0(trimws(deparse(sys.calls()[[1]])), collapse = " ")
|
||||
syscalls <- paste0(trimws(deparse(sys.calls())), collapse = " ")
|
||||
el1 <- gsub("(.*),.*", "\\1", el1)
|
||||
syscall %like% paste0("[^_a-zA-Z0-9]any\\(", "(c\\()?", el1)
|
||||
syscalls %like% paste0("[^_a-zA-Z0-9]any\\(", "(c\\()?", el1)
|
||||
}
|
||||
is_all <- function(el1) {
|
||||
syscall <- paste0(trimws(deparse(sys.calls()[[1]])), collapse = " ")
|
||||
syscalls <- paste0(trimws(deparse(sys.calls())), collapse = " ")
|
||||
el1 <- gsub("(.*),.*", "\\1", el1)
|
||||
syscall %like% paste0("[^_a-zA-Z0-9]all\\(", "(c\\()?", el1)
|
||||
syscalls %like% paste0("[^_a-zA-Z0-9]all\\(", "(c\\()?", el1)
|
||||
}
|
||||
|
||||
find_ab_group <- function(ab_class_args) {
|
||||
@ -714,7 +721,7 @@ find_ab_names <- function(ab_group, n = 3) {
|
||||
}
|
||||
|
||||
message_agent_names <- function(function_name, agents, ab_group = NULL, examples = "", ab_class_args = NULL, call = NULL) {
|
||||
if (message_not_thrown_before(paste0(function_name, ".", paste(sort(agents), collapse = "|")))) {
|
||||
if (message_not_thrown_before(function_name, sort(agents))) {
|
||||
if (length(agents) == 0) {
|
||||
if (is.null(ab_group)) {
|
||||
message_("For `", function_name, "()` no antimicrobial agents found", examples, ".")
|
||||
|
||||
14
R/data.R
14
R/data.R
@ -262,20 +262,24 @@
|
||||
#'
|
||||
#' Data set containing defined intrinsic resistance by EUCAST of all bug-drug combinations.
|
||||
#' @format A [data.frame] with `r format(nrow(intrinsic_resistant), big.mark = ",")` observations and `r ncol(intrinsic_resistant)` variables:
|
||||
#' - `microorganism`\cr Name of the microorganism
|
||||
#' - `antibiotic`\cr Name of the antibiotic drug
|
||||
#' - `microorganism`\cr Official taxonomic name of the microorganism, according to the LPSN
|
||||
#' - `antibiotic`\cr Official name of the antibiotic drug, according to the WHOCC
|
||||
#' @details The repository of this `AMR` package contains a file comprising this exact data set: <https://github.com/msberends/AMR/blob/main/data-raw/intrinsic_resistant.txt>. This file **allows for machine reading EUCAST guidelines about intrinsic resistance**, which is almost impossible with the Excel and PDF files distributed by EUCAST. The file is updated automatically.
|
||||
#'
|
||||
#' This data set is based on `r format_eucast_version_nr(3.2)`.
|
||||
#' This data set is based on `r format_eucast_version_nr(3.3)`.
|
||||
#' @inheritSection AMR Reference Data Publicly Available
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
#' @examples
|
||||
#' subset(intrinsic_resistant,
|
||||
#' antibiotic == "Vancomycin" & microorganism %like% "Enterococcus")$microorganism
|
||||
#' #> [1] "Enterococcus casseliflavus" "Enterococcus gallinarum"
|
||||
#'
|
||||
#' \donttest{
|
||||
#' if (require("dplyr")) {
|
||||
#' intrinsic_resistant %>%
|
||||
#' filter(antibiotic == "Vancomycin", microorganism %like% "Enterococcus") %>%
|
||||
#' filter(antibiotic == "Vancomycin" & microorganism %like% "Enterococcus") %>%
|
||||
#' pull(microorganism)
|
||||
#' # [1] "Enterococcus casseliflavus" "Enterococcus gallinarum"
|
||||
#' #> [1] "Enterococcus casseliflavus" "Enterococcus gallinarum"
|
||||
#' }
|
||||
#' }
|
||||
"intrinsic_resistant"
|
||||
|
||||
@ -305,6 +305,7 @@ eucast_rules <- function(x,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "eucast_rules",
|
||||
...)
|
||||
|
||||
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
|
||||
@ -1055,7 +1056,7 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0)
|
||||
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
|
||||
|
||||
# show used version_breakpoints number once per session (pkg_env will reload every session)
|
||||
if (message_not_thrown_before(paste0("eucast_dosage_v", gsub("[^0-9]", "", version_breakpoints)), entire_session = TRUE)) {
|
||||
if (message_not_thrown_before("eucast_dosage", "v", gsub("[^0-9]", "", version_breakpoints), entire_session = TRUE)) {
|
||||
message_("Dosages for antimicrobial drugs, as meant for ",
|
||||
format_eucast_version_nr(version_breakpoints, markdown = FALSE), ". ",
|
||||
font_red("This note will be shown once per session."))
|
||||
|
||||
@ -256,7 +256,7 @@ first_isolate <- function(x = NULL,
|
||||
if (method == "phenotype-based" & !any_col_contains_rsi) {
|
||||
method <- "episode-based"
|
||||
}
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate.method")) {
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate", "method")) {
|
||||
message_(paste0("Determining first isolates ",
|
||||
ifelse(method %in% c("episode-based", "phenotype-based"),
|
||||
ifelse(is.infinite(episode_days),
|
||||
@ -360,7 +360,7 @@ first_isolate <- function(x = NULL,
|
||||
testcodes_exclude <- NULL
|
||||
}
|
||||
# remove testcodes
|
||||
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate.excludingtestcodes")) {
|
||||
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate", "excludingtestcodes")) {
|
||||
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
@ -373,7 +373,7 @@ first_isolate <- function(x = NULL,
|
||||
# filter on specimen group and keyantibiotics when they are filled in
|
||||
if (!is.null(specimen_group)) {
|
||||
check_columns_existance(col_specimen, x)
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate.excludingspecimen")) {
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate", "excludingspecimen")) {
|
||||
message_("Excluding other than specimen group '", specimen_group, "'",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
@ -445,7 +445,7 @@ first_isolate <- function(x = NULL,
|
||||
|
||||
# Analysis of first isolate ----
|
||||
if (!is.null(col_keyantimicrobials)) {
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate.type")) {
|
||||
if (info == TRUE & message_not_thrown_before("first_isolate", "type")) {
|
||||
if (type == "keyantimicrobials") {
|
||||
message_("Basing inclusion on key antimicrobials, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
|
||||
@ -75,7 +75,8 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
|
||||
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = FALSE)
|
||||
}
|
||||
|
||||
all_found <- get_column_abx(x, info = verbose, only_rsi_columns = only_rsi_columns, verbose = verbose)
|
||||
all_found <- get_column_abx(x, info = verbose, only_rsi_columns = only_rsi_columns,
|
||||
verbose = verbose, fn = "guess_ab_col")
|
||||
search_string.ab <- suppressWarnings(as.ab(search_string))
|
||||
ab_result <- unname(all_found[names(all_found) == search_string.ab])
|
||||
|
||||
@ -104,10 +105,12 @@ get_column_abx <- function(x,
|
||||
info = TRUE,
|
||||
only_rsi_columns = FALSE,
|
||||
sort = TRUE,
|
||||
reuse_previous_result = TRUE) {
|
||||
|
||||
reuse_previous_result = TRUE,
|
||||
fn = NULL) {
|
||||
# check if retrieved before, then get it from package environment
|
||||
if (isTRUE(reuse_previous_result) && identical(unique_call_id(entire_session = FALSE), pkg_env$get_column_abx.call)) {
|
||||
if (isTRUE(reuse_previous_result) && identical(unique_call_id(entire_session = FALSE,
|
||||
match_fn = fn),
|
||||
pkg_env$get_column_abx.call)) {
|
||||
# so within the same call, within the same environment, we got here again.
|
||||
# but we could've come from another function within the same call, so now only check the columns that changed
|
||||
|
||||
@ -194,6 +197,8 @@ get_column_abx <- function(x,
|
||||
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
|
||||
all_okay <- TRUE
|
||||
dots <- list(...)
|
||||
# remove data.frames, since this is also used running `eucast_rules(eucast_rules_df = df)`
|
||||
dots <- dots[!vapply(FUN.VALUE = logical(1), dots, is.data.frame)]
|
||||
if (length(dots) > 0) {
|
||||
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
|
||||
if (any(is.na(newnames))) {
|
||||
@ -228,7 +233,7 @@ get_column_abx <- function(x,
|
||||
if (info == TRUE & all_okay == TRUE) {
|
||||
message_("No columns found.")
|
||||
}
|
||||
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE)
|
||||
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE, match_fn = fn)
|
||||
pkg_env$get_column_abx.checked_cols <- colnames(x.bak)
|
||||
pkg_env$get_column_abx.out <- out
|
||||
return(out)
|
||||
@ -240,32 +245,40 @@ get_column_abx <- function(x,
|
||||
}
|
||||
# only keep the first hits, no duplicates
|
||||
duplicates <- c(out[duplicated(names(out))], out[duplicated(unname(out))])
|
||||
if (length(duplicates) > 0) {
|
||||
all_okay <- FALSE
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
if (all_okay == TRUE) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
} else {
|
||||
message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
}
|
||||
for (i in seq_len(length(out))) {
|
||||
if (verbose == TRUE & !names(out[i]) %in% names(duplicates)) {
|
||||
message_("Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
|
||||
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ").")
|
||||
}
|
||||
if (names(out[i]) %in% names(duplicates)) {
|
||||
already_set_as <- out[unname(out) == unname(out[i])][1L]
|
||||
warning_(paste0("Column '", font_bold(out[i]), "' will not be used for ",
|
||||
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
|
||||
", as it is already set for ",
|
||||
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"),
|
||||
add_fn = font_red,
|
||||
call = FALSE,
|
||||
immediate = verbose)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
out <- out[!duplicated(names(out))]
|
||||
out <- out[!duplicated(unname(out))]
|
||||
if (sort == TRUE) {
|
||||
out <- out[order(names(out), out)]
|
||||
}
|
||||
|
||||
# succeeded with auto-guessing
|
||||
if (info == TRUE & all_okay == TRUE) {
|
||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||
}
|
||||
|
||||
for (i in seq_len(length(out))) {
|
||||
if (info == TRUE & verbose == TRUE & !names(out[i]) %in% names(duplicates)) {
|
||||
message_("Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
|
||||
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ").")
|
||||
}
|
||||
if (info == TRUE & names(out[i]) %in% names(duplicates)) {
|
||||
warning_(paste0("Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
|
||||
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL),
|
||||
"), although it was matched for multiple antibiotics or columns."),
|
||||
add_fn = font_red,
|
||||
call = FALSE,
|
||||
immediate = verbose)
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.null(hard_dependencies)) {
|
||||
hard_dependencies <- unique(hard_dependencies)
|
||||
if (!all(hard_dependencies %in% names(out))) {
|
||||
@ -288,7 +301,7 @@ get_column_abx <- function(x,
|
||||
}
|
||||
}
|
||||
|
||||
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE)
|
||||
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE, match_fn = fn)
|
||||
pkg_env$get_column_abx.checked_cols <- colnames(x.bak)
|
||||
pkg_env$get_column_abx.out <- out
|
||||
out
|
||||
|
||||
@ -142,7 +142,7 @@ key_antimicrobials <- function(x = NULL,
|
||||
|
||||
# force regular data.frame, not a tibble or data.table
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
cols <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns)
|
||||
cols <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns, fn = "key_antimicrobials")
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
@ -171,7 +171,7 @@ key_antimicrobials <- function(x = NULL,
|
||||
|
||||
if (values_new_length < values_old_length &
|
||||
any(filter, na.rm = TRUE) &
|
||||
message_not_thrown_before(paste0("key_antimicrobials.", name))) {
|
||||
message_not_thrown_before("key_antimicrobials", name)) {
|
||||
warning_(ifelse(values_new_length == 0,
|
||||
"No columns available ",
|
||||
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")),
|
||||
@ -238,7 +238,8 @@ all_antimicrobials <- function(x = NULL,
|
||||
|
||||
# force regular data.frame, not a tibble or data.table
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
cols <- get_column_abx(x, only_rsi_columns = only_rsi_columns, info = FALSE, sort = FALSE)
|
||||
cols <- get_column_abx(x, only_rsi_columns = only_rsi_columns, info = FALSE,
|
||||
sort = FALSE, fn = "all_antimicrobials")
|
||||
|
||||
generate_antimcrobials_string(x[ , cols, drop = FALSE])
|
||||
}
|
||||
|
||||
2
R/like.R
2
R/like.R
@ -69,7 +69,7 @@
|
||||
#' # get isolates whose name start with 'Ent' or 'ent'
|
||||
#' example_isolates[which(mo_name(example_isolates$mo) %like% "^ent"), ]
|
||||
#' \donttest{
|
||||
#' # faster way, only works in R 3.2 and later:
|
||||
#' # faster way, since mo_name() is context-aware:
|
||||
#' example_isolates[which(mo_name() %like% "^ent"), ]
|
||||
#'
|
||||
#' if (require("dplyr")) {
|
||||
|
||||
128
R/mdro.R
128
R/mdro.R
@ -51,7 +51,11 @@
|
||||
#'
|
||||
#' Magiorakos AP, Srinivasan A *et al.* "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." Clinical Microbiology and Infection (2012) ([link](https://www.clinicalmicrobiologyandinfection.com/article/S1198-743X(14)61632-3/fulltext))
|
||||
#'
|
||||
#' * `guideline = "EUCAST3.2"` (or simply `guideline = "EUCAST"`)
|
||||
#' * `guideline = "EUCAST3.3"` (or simply `guideline = "EUCAST"`)
|
||||
#'
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.3 "Intrinsic Resistance and Unusual Phenotypes" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2021/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.3_20211018.pdf))
|
||||
#'
|
||||
#' * `guideline = "EUCAST3.2"`
|
||||
#'
|
||||
#' The European international guideline - EUCAST Expert Rules Version 3.2 "Intrinsic Resistance and Unusual Phenotypes" ([link](https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf))
|
||||
#'
|
||||
@ -73,7 +77,6 @@
|
||||
#'
|
||||
#' Please suggest your own (country-specific) guidelines by letting us know: <https://github.com/msberends/AMR/issues/new>.
|
||||
#'
|
||||
#'
|
||||
#' @section Using Custom Guidelines:
|
||||
#'
|
||||
#' Custom guidelines can be set with the [custom_mdro_guideline()] function. This is of great importance if you have custom rules to determine MDROs in your hospital, e.g., rules that are dependent on ward, state of contact isolation or other variables in your data.
|
||||
@ -325,10 +328,17 @@ mdro <- function(x = NULL,
|
||||
} else if (guideline$code == "eucast3.2") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.2, 2020"
|
||||
guideline$version <- "3.2, February 2020"
|
||||
guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf"
|
||||
guideline$type <- "EUCAST Unusual Phenotypes"
|
||||
|
||||
} else if (guideline$code == "eucast3.3") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.3, October 2021"
|
||||
guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2021/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.3_20211018.pdf"
|
||||
guideline$type <- "EUCAST Unusual Phenotypes"
|
||||
|
||||
} else if (guideline$code == "tb") {
|
||||
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
|
||||
guideline$author <- "WHO (World Health Organization)"
|
||||
@ -474,6 +484,7 @@ mdro <- function(x = NULL,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
} else if (guideline$code == "eucast3.2") {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
@ -502,6 +513,36 @@ mdro <- function(x = NULL,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
} else if (guideline$code == "eucast3.3") {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
soft_dependencies = c("AMP",
|
||||
"AMX",
|
||||
"CIP",
|
||||
"DAL",
|
||||
"DAP",
|
||||
"ERV",
|
||||
"FDX",
|
||||
"GEN",
|
||||
"LNZ",
|
||||
"MEM",
|
||||
"MTR",
|
||||
"OMC",
|
||||
"ORI",
|
||||
"PEN",
|
||||
"QDA",
|
||||
"RIF",
|
||||
"TEC",
|
||||
"TGC",
|
||||
"TLV",
|
||||
"TOB",
|
||||
"TZD",
|
||||
"VAN"),
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
} else if (guideline$code == "tb") {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
@ -516,6 +557,7 @@ mdro <- function(x = NULL,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
} else if (guideline$code == "mrgn") {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
@ -528,12 +570,14 @@ mdro <- function(x = NULL,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
} else {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
verbose = verbose,
|
||||
info = info,
|
||||
only_rsi_columns = only_rsi_columns,
|
||||
fn = "mdro",
|
||||
...)
|
||||
}
|
||||
if (!"AMP" %in% names(cols_ab) & "AMX" %in% names(cols_ab)) {
|
||||
@ -1171,10 +1215,80 @@ mdro <- function(x = NULL,
|
||||
which(x$genus == "Streptococcus" & x$species == "pneumoniae"),
|
||||
c(carbapenems, VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC, RIF),
|
||||
"any")
|
||||
streps <- MO_lookup[which(MO_lookup$genus == "Streptococcus"), "mo", drop = TRUE]
|
||||
streps_ABCG <- streps[as.mo(streps, Lancefield = TRUE) %in% c("B_STRPT_GRPA", "B_STRPT_GRPB", "B_STRPT_GRPC", "B_STRPT_GRPG")]
|
||||
trans_tbl(3, # Sr. groups A/B/C/G
|
||||
which(x$mo %in% streps_ABCG),
|
||||
which(x$mo %in% MO_STREP_ABCG),
|
||||
c(PEN, cephalosporins, VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Enterococcus"),
|
||||
c(DAP, LNZ, TGC, ERV, OMC, TEC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Enterococcus" & x$species == "faecalis"),
|
||||
c(AMP, AMX),
|
||||
"any")
|
||||
# Table 8
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Bacteroides"),
|
||||
MTR,
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Clostridium" & x$species == "difficile"),
|
||||
c(MTR, VAN, FDX),
|
||||
"any")
|
||||
}
|
||||
|
||||
if (guideline$code == "eucast3.3") {
|
||||
# EUCAST 3.3 --------------------------------------------------------------
|
||||
# note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed
|
||||
# Table 6
|
||||
trans_tbl(3,
|
||||
which((x$order == "Enterobacterales" &
|
||||
!x$family == "Morganellaceae" &
|
||||
!(x$genus == "Serratia" & x$species == "marcescens"))
|
||||
| (x$genus == "Pseudomonas" & x$species == "aeruginosa")
|
||||
| x$genus == "Acinetobacter"),
|
||||
COL,
|
||||
"all")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Salmonella" & x$species == "Typhi"),
|
||||
c(carbapenems),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Haemophilus" & x$species == "influenzae"),
|
||||
c(cephalosporins_3rd, carbapenems, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Moraxella" & x$species == "catarrhalis"),
|
||||
c(cephalosporins_3rd, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Neisseria" & x$species == "meningitidis"),
|
||||
c(cephalosporins_3rd, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Neisseria" & x$species == "gonorrhoeae"),
|
||||
SPT,
|
||||
"any")
|
||||
# Table 7
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Staphylococcus" & x$species == "aureus"),
|
||||
c(VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$mo %in% MO_CONS), # coagulase-negative Staphylococcus
|
||||
c(VAN, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Corynebacterium"),
|
||||
c(VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(x$genus == "Streptococcus" & x$species == "pneumoniae"),
|
||||
c(carbapenems, VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC, RIF),
|
||||
"any")
|
||||
trans_tbl(3, # Sr. groups A/B/C/G
|
||||
which(x$mo %in% MO_STREP_ABCG),
|
||||
c(PEN, cephalosporins, VAN, TEC, TLV, DAL, ORI, DAP, LNZ, TZD, QDA, TGC, ERV, OMC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
@ -1435,7 +1549,7 @@ mdro <- function(x = NULL,
|
||||
# Results ----
|
||||
if (guideline$code == "cmi2012") {
|
||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||
if (message_not_thrown_before("mdro.availability")) {
|
||||
if (message_not_thrown_before("mdro", "availability")) {
|
||||
warning_("NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||
percentage(pct_required_classes), " (set with `pct_required_classes`)", call = FALSE)
|
||||
}
|
||||
|
||||
24
R/mo.R
24
R/mo.R
@ -1481,14 +1481,22 @@ exec_as.mo <- function(x,
|
||||
if (NROW(uncertainties) > 0 & initial_search == TRUE) {
|
||||
uncertainties <- as.list(pm_distinct(uncertainties, input, .keep_all = TRUE))
|
||||
pkg_env$mo_uncertainties <- uncertainties
|
||||
|
||||
plural <- c("", "it", "was")
|
||||
if (length(uncertainties$input) > 1) {
|
||||
plural <- c("s", "them", "were")
|
||||
if (message_not_thrown_before("as.mo", "uncertainties", uncertainties$input)) {
|
||||
plural <- c("", "this", "uncertainty")
|
||||
if (length(uncertainties$input) > 1) {
|
||||
plural <- c("s", "these", "uncertainties")
|
||||
}
|
||||
if (length(uncertainties$input) <= 3) {
|
||||
examples <- vector_and(paste0('"', uncertainties$input,
|
||||
'" (assuming ', font_italic(uncertainties$fullname, collapse = NULL), ")"),
|
||||
quotes = FALSE)
|
||||
} else {
|
||||
examples <- paste0(nr2char(length(uncertainties$input)), " microorganism", plural[1])
|
||||
}
|
||||
msg <- paste0("Function `as.mo()` is uncertain about ", examples,
|
||||
". Run `mo_uncertainties()` to review ", plural[2], " ", plural[3], ".")
|
||||
message_(msg)
|
||||
}
|
||||
msg <- paste0("Translation is uncertain of ", nr2char(length(uncertainties$input)), " microorganism", plural[1],
|
||||
". Use `mo_uncertainties()` to review ", plural[2], ".")
|
||||
message_(msg)
|
||||
}
|
||||
x[already_known] <- x_known
|
||||
}
|
||||
@ -1505,7 +1513,7 @@ exec_as.mo <- function(x,
|
||||
# nolint start
|
||||
# comment below code if all staphylococcal species are categorised as CoNS/CoPS
|
||||
if (any(x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property])) {
|
||||
if (message_not_thrown_before("as.mo_becker")) {
|
||||
if (message_not_thrown_before("as.mo", "becker")) {
|
||||
warning_("Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
|
||||
font_italic(paste("S.",
|
||||
sort(mo_species(unique(x[x %in% MO_lookup[which(MO_lookup$species %in% post_Becker), property]]))),
|
||||
|
||||
@ -46,7 +46,7 @@
|
||||
#'
|
||||
#' Determination of yeasts - [mo_is_yeast()] - will be based on the taxonomic kingdom and class. *Budding yeasts* are fungi of the phylum Ascomycetes, class Saccharomycetes (also called Hemiascomycetes). *True yeasts* are aggregated into the underlying order Saccharomycetales. Thus, for all microorganisms that are fungi and member of the taxonomic class Saccharomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (except when the input is `NA` or the MO code is `UNKNOWN`).
|
||||
#'
|
||||
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.2)`. The [mo_is_intrinsic_resistant()] functions can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
|
||||
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.3)`. The [mo_is_intrinsic_resistant()] functions can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
|
||||
#'
|
||||
#' All output [will be translated][translate] where possible.
|
||||
#'
|
||||
@ -471,9 +471,9 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
|
||||
}
|
||||
|
||||
# show used version number once per session (pkg_env will reload every session)
|
||||
if (message_not_thrown_before("intrinsic_resistant_version.mo", entire_session = TRUE)) {
|
||||
if (message_not_thrown_before("mo_is_intrinsic_resistant", "version.mo", entire_session = TRUE)) {
|
||||
message_("Determining intrinsic resistance based on ",
|
||||
format_eucast_version_nr(3.2, markdown = FALSE), ". ",
|
||||
format_eucast_version_nr(3.3, markdown = FALSE), ". ",
|
||||
font_red("This note will be shown once per session."))
|
||||
}
|
||||
|
||||
|
||||
14
R/rsi.R
14
R/rsi.R
@ -35,10 +35,10 @@
|
||||
#' @inheritParams first_isolate
|
||||
#' @param guideline defaults to the latest included EUCAST guideline, see *Details* for all options
|
||||
#' @param conserve_capped_values a [logical] to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S"
|
||||
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a [logical] to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.2)`.
|
||||
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a [logical] to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.3)`.
|
||||
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [rsi_translation] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [rsi_translation] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
|
||||
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples*
|
||||
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection like `AMX:VAN`). Otherwise: arguments passed on to methods.
|
||||
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
|
||||
#' @details
|
||||
#' ## How it Works
|
||||
#'
|
||||
@ -61,7 +61,7 @@
|
||||
#' your_data %>% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0
|
||||
#' ```
|
||||
#'
|
||||
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.rsi(data)`.
|
||||
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.rsi(your_data)`.
|
||||
#'
|
||||
#' ## Supported Guidelines
|
||||
#'
|
||||
@ -550,7 +550,7 @@ as.rsi.data.frame <- function(x,
|
||||
|
||||
x.bak <- x
|
||||
for (i in seq_len(ncol(x))) {
|
||||
# don't keep factors
|
||||
# don't keep factors, overwriting them is hard
|
||||
if (is.factor(x[, i, drop = TRUE])) {
|
||||
x[, i] <- as.character(x[, i, drop = TRUE])
|
||||
}
|
||||
@ -775,7 +775,7 @@ exec_as.rsi <- function(method,
|
||||
|
||||
guideline_coerced <- get_guideline(guideline, reference_data)
|
||||
if (guideline_coerced != guideline) {
|
||||
if (message_not_thrown_before("as.rsi")) {
|
||||
if (message_not_thrown_before("as.rsi", "msg1")) {
|
||||
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
|
||||
}
|
||||
}
|
||||
@ -813,7 +813,7 @@ exec_as.rsi <- function(method,
|
||||
|
||||
if (isTRUE(add_intrinsic_resistance) & is_intrinsic_r) {
|
||||
if (guideline_coerced %unlike% "EUCAST") {
|
||||
if (message_not_thrown_before("as.rsi2")) {
|
||||
if (message_not_thrown_before("as.rsi", "msg2")) {
|
||||
warning_("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call = FALSE)
|
||||
}
|
||||
} else {
|
||||
@ -877,7 +877,7 @@ exec_as.rsi <- function(method,
|
||||
if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) {
|
||||
# found some intrinsic resistance, but was not applied
|
||||
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
if (message_not_thrown_before("as.rsi3")) {
|
||||
if (message_not_thrown_before("as.rsi", "msg3")) {
|
||||
warning_("Found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.", call = FALSE)
|
||||
}
|
||||
warned <- TRUE
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
24
R/vctrs.R
24
R/vctrs.R
@ -28,6 +28,18 @@
|
||||
# They are to convert AMR-specific classes to bare characters and integers.
|
||||
# All of them will be exported using s3_register() in R/zzz.R when loading the package.
|
||||
|
||||
# S3: ab_selector
|
||||
# see https://github.com/tidyverse/dplyr/issues/5955 why this is required
|
||||
vec_ptype2.character.ab_selector <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
vec_ptype2.ab_selector.character <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
vec_cast.character.ab_selector <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
# S3: ab
|
||||
vec_ptype2.character.ab <- function(x, y, ...) {
|
||||
x
|
||||
@ -60,15 +72,3 @@ vec_ptype2.disk.integer <- function(x, y, ...) {
|
||||
vec_cast.integer.disk <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
# S3: ab_selector
|
||||
# see https://github.com/tidyverse/dplyr/issues/5955 why this is required
|
||||
vec_ptype2.character.ab_selector <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
vec_ptype2.ab_selector.character <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
vec_cast.character.ab_selector <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user