1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 11:01:57 +02:00

(v1.7.1.9022) rely on vctrs for ab selectors

This commit is contained in:
2021-07-23 21:42:11 +02:00
parent 0ec81cc12e
commit 4e1efd902c
130 changed files with 3785 additions and 2960 deletions

View File

@ -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() {

View File

@ -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"

View File

@ -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(...,

View File

@ -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)

View File

@ -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

View File

@ -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"),

View File

@ -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)]
}

View File

@ -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())
#' }
#' }

View File

@ -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])

View File

@ -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_

View File

@ -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 {

View File

@ -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"

View File

@ -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
View File

@ -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
}

View File

@ -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")
}
}

Binary file not shown.

74
R/vctrs.R Normal file
View 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
View File

@ -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"))