mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 09:11:51 +02:00
(v1.7.1.9005) ab class selectors for R-3.0 and R-3.1
This commit is contained in:
@ -170,65 +170,73 @@ search_type_in_df <- function(x, type, info = TRUE) {
|
||||
|
||||
# remove attributes from other packages
|
||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||
colnames(x) <- trimws(colnames(x))
|
||||
colnames_formatted <- tolower(generalise_antibiotic_name(colnames(x)))
|
||||
|
||||
# -- mo
|
||||
if (type == "mo") {
|
||||
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
|
||||
found <- sort(colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)])[1]
|
||||
} else if ("mo" %in% colnames(x) &
|
||||
suppressWarnings(
|
||||
all(x$mo %in% c(NA, microorganisms$mo)))) {
|
||||
# take first <mo> column
|
||||
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
|
||||
} else if ("mo" %in% colnames_formatted &
|
||||
suppressWarnings(all(x$mo %in% c(NA, microorganisms$mo)))) {
|
||||
found <- "mo"
|
||||
} else if (any(colnames(x) %like% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"])[1]
|
||||
} else if (any(colnames(x) %like% "^(microorganism|organism|bacteria|ba[ck]terie)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(microorganism|organism|bacteria|ba[ck]terie)"])[1]
|
||||
} else if (any(colnames(x) %like% "species")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "species"])[1]
|
||||
} else if (any(colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(mo|microorganism|organism|bacteria|ba[ck]terie)s?$"])
|
||||
} else if (any(colnames_formatted %like_case% "^(microorganism|organism|bacteria|ba[ck]terie)")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(microorganism|organism|bacteria|ba[ck]terie)"])
|
||||
} else if (any(colnames_formatted %like_case% "species")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "species"])
|
||||
}
|
||||
|
||||
}
|
||||
# -- key antibiotics
|
||||
if (type %in% c("keyantibiotics", "keyantimicrobials")) {
|
||||
if (any(colnames(x) %like% "^key.*(ab|antibiotics|antimicrobials)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^key.*(ab|antibiotics|antimicrobials)"])[1]
|
||||
if (any(colnames_formatted %like_case% "^key.*(ab|antibiotics|antimicrobials)")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^key.*(ab|antibiotics|antimicrobials)"])
|
||||
}
|
||||
}
|
||||
# -- date
|
||||
if (type == "date") {
|
||||
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
|
||||
if (any(colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)")) {
|
||||
# WHONET support
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"])[1]
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
|
||||
if (!any(class(pm_pull(x, found)) %in% c("Date", "POSIXct"))) {
|
||||
stop(font_red(paste0("Found column '", font_bold(found), "' to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
|
||||
call. = FALSE)
|
||||
}
|
||||
|
||||
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
||||
found <- sort(colnames(x)[vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct")))])[1]
|
||||
# take first <Date> column
|
||||
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct")))]
|
||||
}
|
||||
}
|
||||
# -- patient id
|
||||
if (type == "patient_id") {
|
||||
if (any(colnames(x) %like% "^(identification |patient|patid)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(identification |patient|patid)"])[1]
|
||||
crit1 <- colnames_formatted %like_case% "^(patient|patid)"
|
||||
if (any(crit1)) {
|
||||
found <- colnames(x)[crit1]
|
||||
} else {
|
||||
crit2 <- colnames_formatted %like_case% "(identification |patient|pat.*id)"
|
||||
if (any(crit2)) {
|
||||
found <- colnames(x)[crit2]
|
||||
}
|
||||
}
|
||||
}
|
||||
# -- specimen
|
||||
if (type == "specimen") {
|
||||
if (any(colnames(x) %like% "(specimen type|spec_type)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "(specimen type|spec_type)"])[1]
|
||||
} else if (any(colnames(x) %like% "^(specimen)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "^(specimen)"])[1]
|
||||
if (any(colnames_formatted %like_case% "(specimen type|spec_type)")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "(specimen type|spec_type)"])
|
||||
} else if (any(colnames_formatted %like_case% "^(specimen)")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen)"])
|
||||
}
|
||||
}
|
||||
# -- UTI (urinary tract infection)
|
||||
if (type == "uti") {
|
||||
if (any(colnames(x) == "uti")) {
|
||||
found <- colnames(x)[colnames(x) == "uti"][1]
|
||||
} else if (any(colnames(x) %like% "(urine|urinary)")) {
|
||||
found <- sort(colnames(x)[colnames(x) %like% "(urine|urinary)"])[1]
|
||||
if (any(colnames_formatted == "uti")) {
|
||||
found <- colnames(x)[colnames_formatted == "uti"]
|
||||
} else if (any(colnames_formatted %like_case% "(urine|urinary)")) {
|
||||
found <- sort(colnames(x)[colnames_formatted %like_case% "(urine|urinary)"])
|
||||
}
|
||||
if (!is.null(found)) {
|
||||
# this column should contain logicals
|
||||
@ -241,10 +249,12 @@ 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))) {
|
||||
msg <- paste0("Using column '", font_bold(found), "' as input for `col_", type, "`.")
|
||||
if (type %in% c("keyantibiotics", "specimen")) {
|
||||
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
|
||||
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
|
||||
}
|
||||
message_(msg)
|
||||
@ -696,7 +706,7 @@ meet_criteria <- function(object,
|
||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||
"be a finite number",
|
||||
"all be finite numbers"),
|
||||
" (i.e., not be infinite)",
|
||||
" (i.e. not be infinite)",
|
||||
call = call_depth)
|
||||
}
|
||||
if (!is.null(contains_column_class)) {
|
||||
@ -713,13 +723,7 @@ meet_criteria <- function(object,
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
get_current_data <- function(arg_name, call, reuse_from_1st_call = TRUE) {
|
||||
# check if retrieved before, then get it from package environment to improve speed
|
||||
if (reuse_from_1st_call == TRUE &&
|
||||
identical(unique_call_id(entire_session = FALSE), pkg_env$get_current_data.call)) {
|
||||
return(pkg_env$get_current_data.out)
|
||||
}
|
||||
|
||||
get_current_data <- function(arg_name, call) {
|
||||
# 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
|
||||
@ -727,73 +731,32 @@ get_current_data <- function(arg_name, call, reuse_from_1st_call = TRUE) {
|
||||
if (!is.null(cur_data_all)) {
|
||||
out <- tryCatch(cur_data_all(), error = function(e) NULL)
|
||||
if (is.data.frame(out)) {
|
||||
out <- structure(out, type = "dplyr_cur_data_all")
|
||||
pkg_env$get_current_data.call <- unique_call_id(entire_session = FALSE)
|
||||
pkg_env$get_current_data.out <- out
|
||||
return(out)
|
||||
}
|
||||
}
|
||||
|
||||
if (getRversion() < "3.2") {
|
||||
# R-3.0 and R-3.1 do not have an `x` element in the call stack, rendering this function useless
|
||||
# R-3.2 was released in April 2015
|
||||
if (is.na(arg_name)) {
|
||||
# such as for carbapenems() etc.
|
||||
warning_("this function requires R version 3.2 or later - you have ", R.version.string, call = call)
|
||||
return(data.frame())
|
||||
} else {
|
||||
# mimic a default R error, e.g. for example_isolates[which(mo_name() %like% "^ent"), ]
|
||||
stop_("argument `", arg_name, "` is missing with no default", call = call)
|
||||
return(structure(out, type = "dplyr_cur_data_all"))
|
||||
}
|
||||
}
|
||||
|
||||
# try a (base R) method, by going over the complete system call stack with sys.frames()
|
||||
not_set <- TRUE
|
||||
source <- "base_R"
|
||||
frms <- lapply(sys.frames(), function(el) {
|
||||
if (not_set == TRUE && ".Generic" %in% names(el)) {
|
||||
if (tryCatch(".data" %in% names(el) && is.data.frame(el$`.data`), error = function(e) FALSE)) {
|
||||
# - - - -
|
||||
# dplyr
|
||||
# - - - -
|
||||
# an element `.data` will be in the system call stack when using dplyr::select()
|
||||
# [but not when using dplyr::filter(), dplyr::mutate() or dplyr::summarise()]
|
||||
not_set <<- FALSE
|
||||
source <<- "dplyr_selector"
|
||||
el$`.data`
|
||||
} else if (tryCatch(any(c("x", "xx") %in% names(el)), error = function(e) FALSE)) {
|
||||
# - - - -
|
||||
# base R
|
||||
# - - - -
|
||||
# an element `x` will be in this environment for only cols, e.g. `example_isolates[, carbapenems()]`
|
||||
# an element `xx` will be in this environment for rows + cols, e.g. `example_isolates[c(1:3), carbapenems()]`
|
||||
if (tryCatch(is.data.frame(el$xx), error = function(e) FALSE)) {
|
||||
not_set <<- FALSE
|
||||
el$xx
|
||||
} else if (tryCatch(is.data.frame(el$x))) {
|
||||
not_set <<- FALSE
|
||||
el$x
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
# try a manual (base R) method, by going over all underlying environments with sys.frames()
|
||||
for (el in sys.frames()) {
|
||||
if (!is.null(el$`.Generic`)) {
|
||||
# don't check `".Generic" %in% names(el)`, because in R < 3.2, `names(el)` is always NULL
|
||||
|
||||
if (!is.null(el$`.data`) && is.data.frame(el$`.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(el$`.data`, type = "dplyr_selector"))
|
||||
|
||||
} else if (!is.null(el$xx) && is.data.frame(el$xx)) {
|
||||
# an element `xx` will be in the environment for rows + cols, e.g. `example_isolates[c(1:3), carbapenems()]`
|
||||
return(structure(el$xx, type = "base_R"))
|
||||
|
||||
} else if (!is.null(el$x) && is.data.frame(el$x)) {
|
||||
# an element `x` will be in the environment for only cols, e.g. `example_isolates[, carbapenems()]`
|
||||
return(structure(el$x, type = "base_R"))
|
||||
}
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
})
|
||||
|
||||
# lookup the matched frame and return its value: a data.frame
|
||||
vars_df <- tryCatch(frms[[which(!vapply(FUN.VALUE = logical(1), frms, is.null))]], error = function(e) NULL)
|
||||
if (is.data.frame(vars_df)) {
|
||||
out <- structure(vars_df, type = source)
|
||||
pkg_env$get_current_data.call <- unique_call_id(entire_session = FALSE)
|
||||
pkg_env$get_current_data.out <- out
|
||||
return(out)
|
||||
}
|
||||
|
||||
# nothing worked, so:
|
||||
# no data.frame found, so an error must be returned:
|
||||
if (is.na(arg_name)) {
|
||||
if (isTRUE(is.numeric(call))) {
|
||||
fn <- as.character(sys.call(call + 1)[1])
|
||||
@ -982,8 +945,8 @@ font_grey_bg <- function(..., collapse = " ") {
|
||||
# similar to HTML #444444
|
||||
try_colour(..., before = "\033[48;5;238m", after = "\033[49m", collapse = collapse)
|
||||
} else {
|
||||
# similar to HTML #eeeeee
|
||||
try_colour(..., before = "\033[48;5;254m", after = "\033[49m", collapse = collapse)
|
||||
# similar to HTML #f0f0f0
|
||||
try_colour(..., before = "\033[48;5;255m", after = "\033[49m", collapse = collapse)
|
||||
}
|
||||
}
|
||||
font_green_bg <- function(..., collapse = " ") {
|
||||
|
||||
@ -25,13 +25,12 @@
|
||||
|
||||
#' Antibiotic Class Selectors
|
||||
#'
|
||||
#' These functions allow for filtering rows and selecting columns based on antibiotic test results that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations. \strong{\Sexpr{ifelse(getRversion() < "3.2", paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
|
||||
#' These functions allow for filtering rows and selecting columns based on antibiotic test results that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
|
||||
#' @inheritSection lifecycle Stable Lifecycle
|
||||
#' @param ab_class an antimicrobial class, such as `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
|
||||
#' @param only_rsi_columns a [logical] to indicate whether only columns of class `<rsi>` must be selected (defaults to `FALSE`), see [as.rsi()]
|
||||
#' @details \strong{\Sexpr{ifelse(getRversion() < "3.2", paste0("NOTE: THESE FUNCTIONS DO NOT WORK ON YOUR CURRENT R VERSION. These functions require R version 3.2 or later - you have ", R.version.string, "."), "")}}
|
||||
#'
|
||||
#' These functions can be used in data set calls for selecting columns and filtering rows, see *Examples*. They support base R, but work more convenient in dplyr functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()].
|
||||
#' @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](https://tidyselect.r-lib.org/reference/language.html), 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.
|
||||
#'
|
||||
@ -267,18 +266,9 @@ ab_selector <- function(function_name,
|
||||
meet_criteria(function_name, allow_class = "character", has_length = 1, allow_NULL = TRUE, .call_depth = 1)
|
||||
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = 1)
|
||||
meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE, .call_depth = 1)
|
||||
|
||||
if (getRversion() < "3.2") {
|
||||
# get_current_data() does not work on R 3.0 and R 3.1.
|
||||
# R 3.2 was released in April 2015.
|
||||
warning_("antibiotic class selectors such as ", function_name,
|
||||
"() require R version 3.2 or later - you have ", R.version.string,
|
||||
call = FALSE)
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
|
||||
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
|
||||
vars_df <- get_current_data(arg_name = NA, call = -3, reuse_from_1st_call = FALSE)
|
||||
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)
|
||||
|
||||
@ -315,12 +305,15 @@ ab_selector <- function(function_name,
|
||||
} else {
|
||||
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
||||
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
||||
need_name <- tolower(gsub("[^a-zA-Z]", "", agents)) != tolower(gsub("[^a-zA-Z]", "", agents_names))
|
||||
agents_formatted[need_name] <- paste0(agents_formatted[need_name],
|
||||
" (", agents_names[need_name], ")")
|
||||
message_("For `", function_name, "(", ifelse(function_name == "ab_class", paste0("\"", ab_class, "\""), ""), ")` using ",
|
||||
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
||||
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
|
||||
message_("For `", function_name, "(",
|
||||
ifelse(function_name == "ab_class",
|
||||
paste0("\"", ab_class, "\""),
|
||||
""),
|
||||
")` using ",
|
||||
ifelse(length(agents) == 1, "column: ", "columns: "),
|
||||
vector_and(agents_formatted, quotes = FALSE))
|
||||
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
|
||||
}
|
||||
remember_thrown_message(function_name)
|
||||
}
|
||||
|
||||
@ -62,7 +62,7 @@ filter_first_weighted_isolate <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
@ -104,7 +104,7 @@ key_antibiotics <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
|
||||
key_antimicrobials(x = x,
|
||||
@ -170,7 +170,7 @@ filter_ab_class <- function(x,
|
||||
if (missing(x) || is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- get_current_data(arg_name = "x", call = -2 - .call_depth, reuse_from_1st_call = FALSE)
|
||||
x <- get_current_data(arg_name = "x", call = -2 - .call_depth)
|
||||
.x_name <- "your_data"
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
|
||||
|
||||
@ -131,11 +131,8 @@
|
||||
#' # `example_isolates` is a data set available in the AMR package.
|
||||
#' # See ?example_isolates.
|
||||
#'
|
||||
#' example_isolates[first_isolate(example_isolates), ]
|
||||
#' \donttest{
|
||||
#' # faster way, only works in R 3.2 and later:
|
||||
#' example_isolates[first_isolate(), ]
|
||||
#'
|
||||
#' \donttest{
|
||||
#' # get all first Gram-negatives
|
||||
#' example_isolates[which(first_isolate() & mo_is_gram_negative()), ]
|
||||
#'
|
||||
@ -207,7 +204,7 @@ first_isolate <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
@ -618,7 +615,7 @@ filter_first_isolate <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||
|
||||
@ -36,7 +36,7 @@
|
||||
#' @param ... ignored, only in place to allow future extensions
|
||||
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.
|
||||
#'
|
||||
#' If the `dplyr` package is installed, their join functions will be used. Otherwise, the much slower [merge()] and [interaction()] functions from base R will be used.
|
||||
#' If the `dplyr` package is installed, their join functions will be used. Otherwise, the much slower [merge()] and [interaction()] functions from base \R will be used.
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
#' @return a [data.frame]
|
||||
#' @export
|
||||
|
||||
@ -130,7 +130,7 @@ key_antimicrobials <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, allow_NA = TRUE, is_in = colnames(x))
|
||||
@ -232,7 +232,7 @@ all_antimicrobials <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
|
||||
|
||||
2
R/mdro.R
2
R/mdro.R
@ -170,7 +170,7 @@ mdro <- function(x = NULL,
|
||||
if (is_null_or_grouped_tbl(x)) {
|
||||
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
|
||||
# is also fix for using a grouped df as input (a dot as first argument)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2, reuse_from_1st_call = FALSE), error = function(e) x)
|
||||
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
|
||||
}
|
||||
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
|
||||
meet_criteria(guideline, allow_class = c("list", "character"), allow_NULL = TRUE)
|
||||
|
||||
4
R/mo.R
4
R/mo.R
@ -1664,9 +1664,7 @@ pillar_shaft.mo <- function(x, ...) {
|
||||
out[is.na(x)] <- font_na(" NA")
|
||||
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
||||
|
||||
df <- tryCatch(get_current_data(arg_name = "x",
|
||||
call = 0,
|
||||
reuse_from_1st_call = FALSE),
|
||||
df <- tryCatch(get_current_data(arg_name = "x", call = 0),
|
||||
error = function(e) NULL)
|
||||
if (!is.null(df)) {
|
||||
mo_cols <- vapply(FUN.VALUE = logical(1), df, is.mo)
|
||||
|
||||
@ -747,16 +747,14 @@ mo_validate <- function(x, property, language, ...) {
|
||||
find_mo_col <- function(fn) {
|
||||
# this function tries to find an mo column in the data the function was called in,
|
||||
# which is useful when functions are used within dplyr verbs
|
||||
df <- get_current_data(arg_name = "x",
|
||||
call = -3,
|
||||
reuse_from_1st_call = FALSE) # will return an error if not found
|
||||
df <- get_current_data(arg_name = "x", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try({
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
}, silent = TRUE)
|
||||
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, "()")
|
||||
message_("Using column '", font_bold(mo), "' as input for `", fn, "()`")
|
||||
remember_thrown_message(fn = fn)
|
||||
}
|
||||
return(df[, mo, drop = TRUE])
|
||||
|
||||
2
R/plot.R
2
R/plot.R
@ -25,7 +25,7 @@
|
||||
|
||||
#' Plotting for Classes `rsi`, `mic` and `disk`
|
||||
#'
|
||||
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base R and `ggplot2`.
|
||||
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base \R and `ggplot2`.
|
||||
#' @inheritSection lifecycle Stable Lifecycle
|
||||
#' @inheritSection AMR Read more on Our Website!
|
||||
#' @param x,data MIC values created with [as.mic()] or disk diffusion values created with [as.disk()]
|
||||
|
||||
10
R/random.R
10
R/random.R
@ -32,7 +32,7 @@
|
||||
#' @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)
|
||||
#' @param ... ignored, only in place to allow future extensions
|
||||
#' @details The base R function [sample()] is used for generating values.
|
||||
#' @details The base \R function [sample()] is used for generating values.
|
||||
#'
|
||||
#' Generated values are based on the latest EUCAST guideline implemented in the [rsi_translation] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument.
|
||||
#' @return class `<mic>` for [random_mic()] (see [as.mic()]) and class `<disk>` for [random_disk()] (see [as.disk()])
|
||||
@ -56,18 +56,26 @@
|
||||
#' 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)
|
||||
meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
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)
|
||||
meet_criteria(mo, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ab, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
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)
|
||||
meet_criteria(prob_RSI, allow_class = c("numeric", "integer"), has_length = 3)
|
||||
sample(as.rsi(c("R", "S", "I")), size = size, replace = TRUE, prob = prob_RSI)
|
||||
}
|
||||
|
||||
|
||||
6
R/rsi.R
6
R/rsi.R
@ -349,7 +349,7 @@ as.rsi.mic <- function(x,
|
||||
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0, reuse_from_1st_call = FALSE)), error = function(e) FALSE)) {
|
||||
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
|
||||
# try to get current column, which will only be available when in across()
|
||||
ab <- tryCatch(cur_column_dplyr(),
|
||||
error = function(e) ab)
|
||||
@ -438,7 +438,7 @@ as.rsi.disk <- function(x,
|
||||
|
||||
# for dplyr's across()
|
||||
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0, reuse_from_1st_call = FALSE)), error = function(e) FALSE)) {
|
||||
if (!is.null(cur_column_dplyr) && tryCatch(is.data.frame(get_current_data("ab", call = 0)), error = function(e) FALSE)) {
|
||||
# try to get current column, which will only be available when in across()
|
||||
ab <- tryCatch(cur_column_dplyr(),
|
||||
error = function(e) ab)
|
||||
@ -448,7 +448,7 @@ as.rsi.disk <- function(x,
|
||||
mo_var_found <- ""
|
||||
if (is.null(mo)) {
|
||||
tryCatch({
|
||||
df <- get_current_data(arg_name = "mo", call = -3, reuse_from_1st_call = FALSE) # will return an error if not found
|
||||
df <- get_current_data(arg_name = "mo", call = -3) # will return an error if not found
|
||||
mo <- NULL
|
||||
try({
|
||||
mo <- suppressMessages(search_type_in_df(df, "mo"))
|
||||
|
||||
Reference in New Issue
Block a user