mirror of
https://github.com/msberends/AMR.git
synced 2025-07-10 00:23:03 +02:00
(v1.7.1.9022) rely on vctrs for ab selectors
This commit is contained in:
@ -135,7 +135,6 @@ check_dataset_integrity <- function() {
|
||||
" the AMR package from working correctly: ",
|
||||
vector_and(overwritten, quotes = "'"),
|
||||
".\nPlease rename your object", plural[3], ".", call = FALSE)
|
||||
remember_thrown_message("dataset_overwritten")
|
||||
}
|
||||
}
|
||||
# check if other packages did not overwrite our data sets
|
||||
@ -258,7 +257,6 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
}
|
||||
message_(msg)
|
||||
remember_thrown_message(fn = paste0("search_", type))
|
||||
}
|
||||
}
|
||||
found
|
||||
@ -771,10 +769,11 @@ get_current_data <- function(arg_name, call) {
|
||||
} else {
|
||||
examples <- ""
|
||||
}
|
||||
stop_("this function must be used inside valid dplyr selection verbs or inside a data.frame call",
|
||||
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
|
||||
examples,
|
||||
call = call)
|
||||
} else {
|
||||
# mimic a base R error that the argument is missing
|
||||
stop_("argument `", arg_name, "` is missing with no default", call = call)
|
||||
}
|
||||
}
|
||||
@ -840,16 +839,18 @@ unique_call_id <- function(entire_session = FALSE) {
|
||||
}
|
||||
}
|
||||
|
||||
remember_thrown_message <- function(fn, entire_session = FALSE) {
|
||||
message_not_thrown_before <- function(fn, entire_session = FALSE) {
|
||||
# this is to prevent that messages/notes will be printed for every dplyr group
|
||||
# e.g. this would show a msg 4 times: example_isolates %>% group_by(hospital_id) %>% filter(mo_is_gram_negative())
|
||||
assign(x = paste0("thrown_msg.", fn),
|
||||
value = unique_call_id(entire_session = entire_session),
|
||||
envir = pkg_env)
|
||||
}
|
||||
|
||||
message_not_thrown_before <- function(fn, entire_session = FALSE) {
|
||||
is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]], unique_call_id(entire_session))
|
||||
test_out <- is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]],
|
||||
unique_call_id(entire_session = entire_session))
|
||||
if (isTRUE(test_out)) {
|
||||
# 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),
|
||||
envir = pkg_env)
|
||||
}
|
||||
test_out
|
||||
}
|
||||
|
||||
has_colour <- function() {
|
||||
|
||||
@ -33,7 +33,7 @@
|
||||
#' @details
|
||||
#' These functions can be used in data set calls for selecting columns and filtering rows. They are heavily inspired by the [Tidyverse selection helpers][tidyselect::language] such as [`everything()`][tidyselect::everything()], but also work in base \R and not only in `dplyr` verbs. Nonetheless, they are very convenient to use with `dplyr` functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()], see *Examples*.
|
||||
#'
|
||||
#' All columns in the data in which these functions are called will be searched for known antibiotic names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) in the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc. Use the [ab_class()] function to filter/select on a manually defined antibiotic class.
|
||||
#' All columns in the data in which these functions are called will be searched for known antibiotic names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc. Use the [ab_class()] function to filter/select on a manually defined antibiotic class.
|
||||
#'
|
||||
#' @section Full list of supported agents:
|
||||
#'
|
||||
@ -312,7 +312,6 @@ ab_selector <- function(function_name,
|
||||
sort = TRUE), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
|
||||
"This warning will be shown once per session.",
|
||||
call = FALSE)
|
||||
remember_thrown_message(paste0("ab_class.untreatable.", function_name), entire_session = TRUE)
|
||||
}
|
||||
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
|
||||
}
|
||||
@ -343,8 +342,8 @@ ab_selector <- function(function_name,
|
||||
|
||||
# get the columns with a group names in the chosen ab class
|
||||
agents <- ab_in_data[names(ab_in_data) %in% abx]
|
||||
|
||||
if (message_not_thrown_before(paste0(function_name, ".", paste(pkg_env$get_column_abx.out, collapse = "|")))) {
|
||||
|
||||
if (message_not_thrown_before(paste0(function_name, ".", paste(sort(agents), collapse = "|")))) {
|
||||
if (length(agents) == 0) {
|
||||
message_("No antimicrobial agents of class '", ab_group, "' found", examples, ".")
|
||||
} else {
|
||||
@ -360,21 +359,10 @@ ab_selector <- function(function_name,
|
||||
ifelse(length(agents) == 1, "column ", "columns "),
|
||||
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
|
||||
}
|
||||
remember_thrown_message(paste0(function_name, ".", paste(pkg_env$get_column_abx.out, collapse = "|")))
|
||||
}
|
||||
|
||||
if (!is.null(attributes(vars_df)$type) &&
|
||||
attributes(vars_df)$type %in% c("dplyr_cur_data_all", "base_R") &&
|
||||
!any(as.character(sys.calls()) %like% paste0("(across|if_any|if_all)\\((c\\()?[a-z(), ]*", function_name))) {
|
||||
structure(unname(agents),
|
||||
class = c("ab_selector", "character"))
|
||||
} else {
|
||||
# don't return with "ab_selector" class if method is a dplyr selector,
|
||||
# dplyr::select() will complain:
|
||||
# > Subscript has the wrong type `ab_selector`.
|
||||
# > It must be numeric or character.
|
||||
unname(agents)
|
||||
}
|
||||
structure(unname(agents),
|
||||
class = c("ab_selector", "character"))
|
||||
}
|
||||
|
||||
#' @method c ab_selector
|
||||
@ -412,7 +400,6 @@ all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
|
||||
#' @export
|
||||
#' @noRd
|
||||
all.ab_selector <- function(..., na.rm = FALSE) {
|
||||
# this is all() for
|
||||
all_any_ab_selector("all", ..., na.rm = na.rm)
|
||||
}
|
||||
|
||||
@ -458,7 +445,6 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
`==.ab_selector` <- function(e1, e2) {
|
||||
calls <- as.character(match.call())
|
||||
fn_name <- calls[2]
|
||||
# keep only the ... in c(...)
|
||||
fn_name <- gsub("^(c\\()(.*)(\\))$", "\\2", fn_name)
|
||||
if (is_any(fn_name)) {
|
||||
type <- "any"
|
||||
@ -481,7 +467,6 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
`!=.ab_selector` <- function(e1, e2) {
|
||||
calls <- as.character(match.call())
|
||||
fn_name <- calls[2]
|
||||
# keep only the ... in c(...)
|
||||
fn_name <- gsub("^(c\\()(.*)(\\))$", "\\2", fn_name)
|
||||
if (is_any(fn_name)) {
|
||||
type <- "any"
|
||||
|
||||
@ -149,7 +149,6 @@ count_R <- function(..., only_all_tested = FALSE) {
|
||||
count_IR <- function(..., only_all_tested = FALSE) {
|
||||
if (message_not_thrown_before("count_IR", entire_session = TRUE)) {
|
||||
message_("Using `count_IR()` is discouraged; use `count_resistant()` instead to not consider \"I\" being resistant. This note will be shown once for this session.", as_note = FALSE)
|
||||
remember_thrown_message("count_IR")
|
||||
}
|
||||
tryCatch(
|
||||
rsi_calc(...,
|
||||
@ -186,7 +185,6 @@ count_SI <- function(..., only_all_tested = FALSE) {
|
||||
count_S <- function(..., only_all_tested = FALSE) {
|
||||
if (message_not_thrown_before("count_S", entire_session = TRUE)) {
|
||||
message_("Using `count_S()` is discouraged; use `count_susceptible()` instead to also consider \"I\" being susceptible. This note will be shown once for this session.", as_note = FALSE)
|
||||
remember_thrown_message("count_S")
|
||||
}
|
||||
tryCatch(
|
||||
rsi_calc(...,
|
||||
|
||||
@ -1072,7 +1072,6 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0)
|
||||
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."))
|
||||
remember_thrown_message(paste0("eucast_dosage_v", gsub("[^0-9]", "", version_breakpoints)), entire_session = TRUE)
|
||||
}
|
||||
|
||||
ab <- as.ab(ab)
|
||||
|
||||
@ -264,7 +264,6 @@ first_isolate <- function(x = NULL,
|
||||
"")),
|
||||
as_note = FALSE,
|
||||
add_fn = font_black)
|
||||
remember_thrown_message("first_isolate.method")
|
||||
}
|
||||
|
||||
# try to find columns based on type
|
||||
@ -364,7 +363,6 @@ first_isolate <- function(x = NULL,
|
||||
message_("Excluding test codes: ", toString(paste0("'", testcodes_exclude, "'")),
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
remember_thrown_message("first_isolate.excludingtestcodes")
|
||||
}
|
||||
|
||||
if (is.null(col_specimen)) {
|
||||
@ -378,7 +376,6 @@ first_isolate <- function(x = NULL,
|
||||
message_("Excluding other than specimen group '", specimen_group, "'",
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
remember_thrown_message("first_isolate.excludingspecimen")
|
||||
}
|
||||
}
|
||||
if (!is.null(col_keyantimicrobials)) {
|
||||
@ -474,7 +471,6 @@ first_isolate <- function(x = NULL,
|
||||
add_fn = font_black,
|
||||
as_note = FALSE)
|
||||
}
|
||||
remember_thrown_message("first_isolate.type")
|
||||
}
|
||||
type_param <- type
|
||||
|
||||
|
||||
@ -389,10 +389,11 @@ scale_rsi_colours <- function(...,
|
||||
names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
|
||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
|
||||
"replacement", drop = TRUE]))
|
||||
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure", "Increased exposure", "Incr. exposure",
|
||||
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure",
|
||||
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
|
||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
|
||||
"replacement", drop = TRUE]),
|
||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Incr. exposure"),
|
||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
|
||||
"replacement", drop = TRUE]))
|
||||
names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
|
||||
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
|
||||
|
||||
@ -121,7 +121,7 @@ get_column_abx <- function(x,
|
||||
# these columns did not exist in the last call, so add them
|
||||
new_cols_rsi <- get_column_abx(x[, new_cols, drop = FALSE], reuse_previous_result = FALSE, info = FALSE, sort = FALSE)
|
||||
current <- c(current, new_cols_rsi)
|
||||
# order according to data in current call
|
||||
# order according to columns in current call
|
||||
current <- current[match(colnames(x)[colnames(x) %in% current], current)]
|
||||
}
|
||||
|
||||
|
||||
@ -44,11 +44,11 @@
|
||||
#' cat(italicise_taxonomy("An overview of S. aureus isolates", type = "ansi"))
|
||||
#'
|
||||
#' # since ggplot2 supports no markdown (yet), use
|
||||
#' # italicise_taxonomy() and the `ggtext` pkg for titles:
|
||||
#' # italicise_taxonomy() and the `ggtext` package for titles:
|
||||
#' \donttest{
|
||||
#' if (require("ggplot2") && require("ggtext")) {
|
||||
#' ggplot(example_isolates$AMC,
|
||||
#' title = italicise_taxonomy("Amoxi/clav in E. coli")) +
|
||||
#' autoplot(example_isolates$AMC,
|
||||
#' title = italicise_taxonomy("Amoxi/clav in E. coli")) +
|
||||
#' theme(plot.title = ggtext::element_markdown())
|
||||
#' }
|
||||
#' }
|
||||
|
||||
@ -177,7 +177,6 @@ key_antimicrobials <- function(x = NULL,
|
||||
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")),
|
||||
"as key antimicrobials for ", name, "s. See ?key_antimicrobials.",
|
||||
call = FALSE)
|
||||
remember_thrown_message(paste0("key_antimicrobials.", name))
|
||||
}
|
||||
|
||||
generate_antimcrobials_string(x[which(filter), c(universal, values), drop = FALSE])
|
||||
|
||||
11
R/mdro.R
11
R/mdro.R
@ -187,13 +187,9 @@ mdro <- function(x = NULL,
|
||||
check_dataset_integrity()
|
||||
|
||||
info.bak <- info
|
||||
if (message_not_thrown_before("mdro")) {
|
||||
remember_thrown_message("mdro")
|
||||
} else {
|
||||
# don't thrown info's more than once per call
|
||||
info <- FALSE
|
||||
}
|
||||
|
||||
# don't thrown info's more than once per call
|
||||
info <- message_not_thrown_before("mdro")
|
||||
|
||||
if (interactive() & verbose == TRUE & info == TRUE) {
|
||||
txt <- paste0("WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
|
||||
"\n\nThis may overwrite your existing data if you use e.g.:",
|
||||
@ -1416,7 +1412,6 @@ mdro <- function(x = NULL,
|
||||
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)
|
||||
remember_thrown_message("mdro.availability")
|
||||
}
|
||||
# set these -1s to NA
|
||||
x[which(x$MDRO == -1), "MDRO"] <- NA_integer_
|
||||
|
||||
@ -481,7 +481,6 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
|
||||
message_("Determining intrinsic resistance based on ",
|
||||
format_eucast_version_nr(3.2, markdown = FALSE), ". ",
|
||||
font_red("This note will be shown once per session."))
|
||||
remember_thrown_message("intrinsic_resistant_version", entire_session = TRUE)
|
||||
}
|
||||
|
||||
# runs against internal vector: INTRINSIC_R (see zzz.R)
|
||||
@ -758,7 +757,6 @@ find_mo_col <- function(fn) {
|
||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||
if (message_not_thrown_before(fn = fn)) {
|
||||
message_("Using column '", font_bold(mo), "' as input for `", fn, "()`")
|
||||
remember_thrown_message(fn = fn)
|
||||
}
|
||||
return(df[, mo, drop = TRUE])
|
||||
} else {
|
||||
|
||||
6
R/plot.R
6
R/plot.R
@ -265,7 +265,7 @@ autoplot.mic <- function(object,
|
||||
if (any(colours_RSI %in% cols_sub$cols)) {
|
||||
vals <- c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Susceptible, incr. exp." = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
p <- p +
|
||||
@ -482,7 +482,7 @@ autoplot.disk <- function(object,
|
||||
if (any(colours_RSI %in% cols_sub$cols)) {
|
||||
vals <- c("Resistant" = colours_RSI[1],
|
||||
"Susceptible" = colours_RSI[2],
|
||||
"Incr. exposure" = colours_RSI[3],
|
||||
"Susceptible, incr. exp." = colours_RSI[3],
|
||||
"Intermediate" = colours_RSI[3])
|
||||
names(vals) <- translate_AMR(names(vals), language = language)
|
||||
p <- p +
|
||||
@ -686,7 +686,7 @@ plot_prepare_table <- function(x, expand) {
|
||||
plot_name_of_I <- function(guideline) {
|
||||
if (guideline %unlike% "CLSI" && as.double(gsub("[^0-9]+", "", guideline)) >= 2019) {
|
||||
# interpretation since 2019
|
||||
"Incr. exposure"
|
||||
"Susceptible, incr. exp."
|
||||
} else {
|
||||
# interpretation until 2019
|
||||
"Intermediate"
|
||||
|
||||
52
R/random.R
52
R/random.R
@ -27,7 +27,7 @@
|
||||
#'
|
||||
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial agent, the generated results will reflect reality as much as possible.
|
||||
#' @inheritSection lifecycle Stable Lifecycle
|
||||
#' @param size desired size of the returned vector
|
||||
#' @param size desired size of the returned vector. If used in a [data.frame] call or `dplyr` verb, will get the current (group) size if left blank.
|
||||
#' @param mo any [character] that can be coerced to a valid microorganism code with [as.mo()]
|
||||
#' @param ab any [character] that can be coerced to a valid antimicrobial agent code with [as.ab()]
|
||||
#' @param prob_RSI a vector of length 3: the probabilities for R (1st value), S (2nd value) and I (3rd value)
|
||||
@ -55,27 +55,36 @@
|
||||
#' random_disk(100, "Klebsiella pneumoniae", "ampicillin") # range 11-17
|
||||
#' random_disk(100, "Streptococcus pneumoniae", "ampicillin") # range 12-27
|
||||
#' }
|
||||
random_mic <- function(size, mo = NULL, ab = NULL, ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
||||
random_mic <- function(size = NULL, mo = NULL, ab = NULL, ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
|
||||
meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
if (is.null(size)) {
|
||||
size <- NROW(get_current_data(arg_name = "size", call = -3))
|
||||
}
|
||||
random_exec("MIC", size = size, mo = mo, ab = ab)
|
||||
}
|
||||
|
||||
#' @rdname random
|
||||
#' @export
|
||||
random_disk <- function(size, mo = NULL, ab = NULL, ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
||||
random_disk <- function(size = NULL, mo = NULL, ab = NULL, ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
|
||||
meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
if (is.null(size)) {
|
||||
size <- NROW(get_current_data(arg_name = "size", call = -3))
|
||||
}
|
||||
random_exec("DISK", size = size, mo = mo, ab = ab)
|
||||
}
|
||||
|
||||
#' @rdname random
|
||||
#' @export
|
||||
random_rsi <- function(size, prob_RSI = c(0.33, 0.33, 0.33), ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
||||
random_rsi <- function(size = NULL, prob_RSI = c(0.33, 0.33, 0.33), ...) {
|
||||
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
|
||||
meet_criteria(prob_RSI, allow_class = c("numeric", "integer"), has_length = 3)
|
||||
if (is.null(size)) {
|
||||
size <- NROW(get_current_data(arg_name = "size", call = -3))
|
||||
}
|
||||
sample(as.rsi(c("R", "S", "I")), size = size, replace = TRUE, prob = prob_RSI)
|
||||
}
|
||||
|
||||
@ -111,23 +120,22 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
|
||||
warning_("No rows found that match ab '", ab, "', ignoring argument `ab`", call = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (type == "MIC") {
|
||||
# all valid MIC levels
|
||||
valid_range <- as.mic(levels(as.mic(1)))
|
||||
set_range_max <- max(df$breakpoint_R)
|
||||
if (log(set_range_max, 2) %% 1 == 0) {
|
||||
# return powers of 2
|
||||
valid_range <- unique(as.double(valid_range))
|
||||
# add 1-3 higher MIC levels to set_range_max
|
||||
set_range_max <- 2 ^ (log(set_range_max, 2) + sample(c(1:3), 1))
|
||||
set_range <- as.mic(valid_range[log(valid_range, 2) %% 1 == 0 & valid_range <= set_range_max])
|
||||
} else {
|
||||
# no power of 2, return factors of 2 to left and right side
|
||||
valid_mics <- suppressWarnings(as.mic(set_range_max / (2 ^ c(-3:3))))
|
||||
set_range <- valid_mics[!is.na(valid_mics)]
|
||||
# set range
|
||||
mic_range <- c(0.001, 0.002, 0.005, 0.010, 0.025, 0.0625, 0.125, 0.250, 0.5, 1, 2, 4, 8, 16, 32, 64, 128, 256)
|
||||
|
||||
# get highest/lowest +/- random 1 to 3 higher factors of two
|
||||
max_range <- mic_range[min(length(mic_range),
|
||||
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1))]
|
||||
min_range <- mic_range[max(1,
|
||||
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1))]
|
||||
|
||||
mic_range_new <- mic_range[mic_range <= max_range & mic_range >= min_range]
|
||||
if (length(mic_range_new) == 0) {
|
||||
mic_range_new <- mic_range
|
||||
}
|
||||
out <- as.mic(sample(set_range, size = size, replace = TRUE))
|
||||
out <- as.mic(sample(mic_range_new, size = size, replace = TRUE))
|
||||
# 50% chance that lowest will get <= and highest will get >=
|
||||
if (stats::runif(1) > 0.5) {
|
||||
out[out == min(out)] <- paste0("<=", out[out == min(out)])
|
||||
|
||||
12
R/rsi.R
12
R/rsi.R
@ -294,16 +294,15 @@ as.rsi.default <- function(x, ...) {
|
||||
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
|
||||
trans_S <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
|
||||
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
|
||||
trans_I <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern %in% c("Incr. exposure", "Intermediate")),
|
||||
trans_I <- unlist(TRANSLATIONS[which(TRANSLATIONS$pattern %in% c("Incr. exposure", "Susceptible, incr. exp.", "Intermediate")),
|
||||
LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED %in% colnames(TRANSLATIONS)]])
|
||||
x <- gsub(paste0(unique(trans_R[!is.na(trans_R)]), collapse = "|"), "R", x, ignore.case = TRUE)
|
||||
x <- gsub(paste0(unique(trans_S[!is.na(trans_S)]), collapse = "|"), "S", x, ignore.case = TRUE)
|
||||
x <- gsub(paste0(unique(trans_I[!is.na(trans_I)]), collapse = "|"), "I", x, ignore.case = TRUE)
|
||||
# replace all English textual input
|
||||
x <- gsub("res(is(tant)?)?", "R", x, ignore.case = TRUE)
|
||||
x <- gsub("sus(cep(tible)?)?", "S", x, ignore.case = TRUE)
|
||||
x <- gsub("int(er(mediate)?)?", "I", x, ignore.case = TRUE)
|
||||
x <- gsub("inc(r(eased)?)? exp[a-z]*", "I", x, ignore.case = TRUE)
|
||||
x[x %like% "([^a-z]|^)res(is(tant)?)?"] <- "R"
|
||||
x[x %like% "([^a-z]|^)sus(cep(tible)?)?"] <- "S"
|
||||
x[x %like% "([^a-z]|^)int(er(mediate)?)?|incr.*exp"] <- "I"
|
||||
# remove all spaces
|
||||
x <- gsub(" +", "", x)
|
||||
# remove all MIC-like values: numbers, operators and periods
|
||||
@ -776,7 +775,6 @@ exec_as.rsi <- function(method,
|
||||
if (guideline_coerced != guideline) {
|
||||
if (message_not_thrown_before("as.rsi")) {
|
||||
message_("Using guideline ", font_bold(guideline_coerced), " as input for `guideline`.")
|
||||
remember_thrown_message("as.rsi")
|
||||
}
|
||||
}
|
||||
|
||||
@ -815,7 +813,6 @@ exec_as.rsi <- function(method,
|
||||
if (guideline_coerced %unlike% "EUCAST") {
|
||||
if (message_not_thrown_before("as.rsi2")) {
|
||||
warning_("Using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", call = FALSE)
|
||||
remember_thrown_message("as.rsi2")
|
||||
}
|
||||
} else {
|
||||
new_rsi[i] <- "R"
|
||||
@ -880,7 +877,6 @@ exec_as.rsi <- function(method,
|
||||
message_("WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
||||
if (message_not_thrown_before("as.rsi3")) {
|
||||
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)
|
||||
remember_thrown_message("as.rsi3")
|
||||
}
|
||||
warned <- TRUE
|
||||
}
|
||||
|
||||
@ -152,7 +152,6 @@ rsi_calc <- function(...,
|
||||
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n",
|
||||
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
|
||||
call = FALSE)
|
||||
remember_thrown_message("rsi_calc")
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
74
R/vctrs.R
Normal file
74
R/vctrs.R
Normal file
@ -0,0 +1,74 @@
|
||||
# ==================================================================== #
|
||||
# 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/ #
|
||||
# ==================================================================== #
|
||||
|
||||
# These are all S3 implementations for the vctrs package,
|
||||
# that is used internally by tidyverse packages such as dplyr.
|
||||
# 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
|
||||
vec_ptype2.character.ab <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
vec_ptype2.ab.character <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
vec_cast.character.ab <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
# S3: mo
|
||||
vec_ptype2.character.mo <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
vec_ptype2.mo.character <- function(x, y, ...) {
|
||||
y
|
||||
}
|
||||
vec_cast.character.mo <- function(x, to, ...) {
|
||||
unclass(x)
|
||||
}
|
||||
|
||||
# S3: disk
|
||||
vec_ptype2.integer.disk <- function(x, y, ...) {
|
||||
x
|
||||
}
|
||||
vec_ptype2.disk.integer <- function(x, y, ...) {
|
||||
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)
|
||||
}
|
||||
17
R/zzz.R
17
R/zzz.R
@ -56,15 +56,29 @@ if (utf8_supported && !is_latex) {
|
||||
# Support for frequency tables from the cleaner package
|
||||
s3_register("cleaner::freq", "mo")
|
||||
s3_register("cleaner::freq", "rsi")
|
||||
# Support from skim() from the skimr package
|
||||
# Support for skim() from the skimr package
|
||||
s3_register("skimr::get_skimmers", "mo")
|
||||
s3_register("skimr::get_skimmers", "rsi")
|
||||
s3_register("skimr::get_skimmers", "mic")
|
||||
s3_register("skimr::get_skimmers", "disk")
|
||||
# Support for autoplot() from the ggplot2 package
|
||||
s3_register("ggplot2::autoplot", "rsi")
|
||||
s3_register("ggplot2::autoplot", "mic")
|
||||
s3_register("ggplot2::autoplot", "disk")
|
||||
s3_register("ggplot2::autoplot", "resistance_predict")
|
||||
# Support vctrs package for use in e.g. dplyr verbs
|
||||
s3_register("vctrs::vec_ptype2", "ab.character")
|
||||
s3_register("vctrs::vec_ptype2", "character.ab")
|
||||
s3_register("vctrs::vec_cast", "character.ab")
|
||||
s3_register("vctrs::vec_ptype2", "mo.character")
|
||||
s3_register("vctrs::vec_ptype2", "character.mo")
|
||||
s3_register("vctrs::vec_cast", "character.mo")
|
||||
s3_register("vctrs::vec_ptype2", "ab_selector.character")
|
||||
s3_register("vctrs::vec_ptype2", "character.ab_selector")
|
||||
s3_register("vctrs::vec_cast", "character.ab_selector")
|
||||
s3_register("vctrs::vec_ptype2", "disk.integer")
|
||||
s3_register("vctrs::vec_ptype2", "integer.disk")
|
||||
s3_register("vctrs::vec_cast", "integer.disk")
|
||||
|
||||
# if mo source exists, fire it up (see mo_source())
|
||||
try({
|
||||
@ -75,6 +89,7 @@ if (utf8_supported && !is_latex) {
|
||||
|
||||
|
||||
# reference data - they have additional columns compared to `antibiotics` and `microorganisms` to improve speed
|
||||
# they can't be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
|
||||
assign(x = "AB_lookup", value = create_AB_lookup(), envir = asNamespace("AMR"))
|
||||
assign(x = "MO_lookup", value = create_MO_lookup(), envir = asNamespace("AMR"))
|
||||
assign(x = "MO.old_lookup", value = create_MO.old_lookup(), envir = asNamespace("AMR"))
|
||||
|
||||
Reference in New Issue
Block a user