P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 09:51:48 +02:00
Code Releases Activity

(v1.4.0.9056) subsetting ab class selectors for base R

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-01-03 23:40:05 +01:00
parent ecac443f86
commit 63a4dda467
20 changed files with 334 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

77
R/aa_helper_functions.R
View File

@ -527,43 +527,74 @@ meet_criteria <- function(object,
}
get_current_data <- function(arg_name, call) {
# this mimics dplyr::cur_data_all for users that use our context-aware functions in dplyr verbs
cur_data_all_dplyr <- import_fn("cur_data_all", "dplyr", error_on_fail = FALSE)
if (is.null(cur_data_all_dplyr)) {
# dplyr not installed
stop_("argument `", arg_name, "` is missing, with no default", call = call)
# try a (base R) method, by going over the complete system call stack with sys.frames()
not_set <- TRUE
frms <- lapply(sys.frames(), function(el) {
if (tryCatch(not_set == TRUE && ".data" %in% names(el) && is.data.frame(el$`.data`), error = function(e) FALSE)) {
# dplyr? - an element `.data` will be in the system call stack
not_set <<- FALSE
el$`.data`
} else if (tryCatch(not_set == TRUE && any(c("x", "xx") %in% names(el)), error = function(e) FALSE)) {
# otherwise try 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 (is.data.frame(el$xx)) {
not_set <<- FALSE
el$xx
} else if (is.data.frame(el$x)) {
not_set <<- FALSE
el$x
} else {
NULL
}
} else {
NULL
}
})
vars_df <- tryCatch(frms[[which(!vapply(FUN.VALUE = logical(1), frms, is.null))]], error = function(e) NULL)
if (is.data.frame(vars_df)) {
return(vars_df)
}
# nothing worked, so:
if (is.na(arg_name)) {
stop_("this function must be used inside valid dplyr selection verbs or inside a data.frame call",
call = call)
} else {
stop_("argument `", arg_name, "` is missing with no default ",
"or function not used inside a valid dplyr verb",
call = call)
}
tryCatch(cur_data_all_dplyr(),
# dplyr installed, but not used inside dplyr verb
error = function(e) stop_("argument `", arg_name, "` is missing with no default ",
"or function not used inside a valid dplyr verb",
# tryCatch adds 4 system calls, subtract them
call = call - 4))
}
unique_call_id <- function() {
# combination of environment ID (like "0x7fed4ee8c848")
# and highest system call
c(envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]])),
call = paste0(deparse(sys.calls()[[1]]), collapse = ""))
unique_call_id <- function(entire_session = FALSE) {
if (entire_session == TRUE) {
c(envir = "session",
call = "session")
} else {
# combination of environment ID (like "0x7fed4ee8c848")
# and highest system call
c(envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]])),
call = paste0(deparse(sys.calls()[[1]]), collapse = ""))
}
}
remember_thrown_message <- function(fn) {
remember_thrown_message <- 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("uniquecall_", fn),
value = unique_call_id(),
assign(x = paste0("thrown_msg_", fn),
value = unique_call_id(entire_session = entire_session),
envir = pkg_env)
}
message_not_thrown_before <- function(fn) {
is.null(pkg_env[[paste0("uniquecall_", fn)]]) || !identical(pkg_env[[paste0("uniquecall_", fn)]], unique_call_id())
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))
}
reset_all_thrown_messages <- function() {
# for unit tests, where the environment and highest system call do not change
pkg_env_contents <- ls(envir = pkg_env)
rm(list = pkg_env_contents[pkg_env_contents %like% "^uniquecall_"],
rm(list = pkg_env_contents[pkg_env_contents %like% "^thrown_msg_"],
envir = pkg_env)
}
@ -571,7 +602,7 @@ has_colour <- function() {
# this is a base R version of crayon::has_color, but disables colours on emacs
if (Sys.getenv("EMACS") != "" || Sys.getenv("INSIDE_EMACS") != "") {
# disable on emacs, only supports 8 colours
# disable on emacs, which only supports 8 colours
return(FALSE)
}
enabled <- getOption("crayon.enabled")

25
R/ab_class_selectors.R
View File

@ -161,29 +161,8 @@ tetracyclines <- function() {
ab_selector <- function(ab_class, function_name) {
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = 1)
meet_criteria(function_name, allow_class = "character", has_length = 1, .call_depth = 1)
for (i in seq_len(length(sys.frames()))) {
# dplyr?
if (".data" %in% names(sys.frames()[[i]])) {
vars_df <- sys.frames()[[i]]$`.data`
if (is.data.frame(vars_df)) {
break
}
}
# then try base R - an element `x` will be in the system call stack
vars_df <- tryCatch(sys.frames()[[i]]$x, error = function(e) NULL)
if (!is.null(vars_df) && is.data.frame(vars_df)) {
# when using e.g. example_isolates[, carbapenems()] or example_isolates %>% select(carbapenems())
break
} else if (!is.null(vars_df) && is.list(vars_df)) {
# when using e.g. example_isolates %>% filter(across(carbapenems(), ~. == "R"))
vars_df <- tryCatch(as.data.frame(vars_df, stringsAsFactors = FALSE), error = function(e) NULL)
if (!is.null(vars_df)) {
break
}
}
}
stop_ifnot(is.data.frame(vars_df), "this function must be used inside dplyr selection verbs or within a data.frame call.", call = -2)
vars_df <- get_current_data(arg_name = NA, call = -3)
ab_in_data <- get_column_abx(vars_df, info = FALSE)
if (length(ab_in_data) == 0) {

111
R/mo_property.R
View File

@ -162,8 +162,8 @@
#' }
mo_name <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_name")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_name")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -179,8 +179,8 @@ mo_fullname <- mo_name
#' @export
mo_shortname <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_shortname")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_shortname")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -217,8 +217,8 @@ mo_shortname <- function(x, language = get_locale(), ...) {
#' @export
mo_subspecies <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_subspecies")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_subspecies")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -230,8 +230,8 @@ mo_subspecies <- function(x, language = get_locale(), ...) {
#' @export
mo_species <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_species")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_species")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -243,8 +243,8 @@ mo_species <- function(x, language = get_locale(), ...) {
#' @export
mo_genus <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_genus")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_genus")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -256,8 +256,8 @@ mo_genus <- function(x, language = get_locale(), ...) {
#' @export
mo_family <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_family")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_family")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -269,8 +269,8 @@ mo_family <- function(x, language = get_locale(), ...) {
#' @export
mo_order <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_order")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_order")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -282,8 +282,8 @@ mo_order <- function(x, language = get_locale(), ...) {
#' @export
mo_class <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_class")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_class")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -295,8 +295,8 @@ mo_class <- function(x, language = get_locale(), ...) {
#' @export
mo_phylum <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_phylum")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_phylum")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -308,8 +308,8 @@ mo_phylum <- function(x, language = get_locale(), ...) {
#' @export
mo_kingdom <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_kingdom")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_kingdom")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -325,8 +325,8 @@ mo_domain <- mo_kingdom
#' @export
mo_type <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_type")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_type")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -338,8 +338,8 @@ mo_type <- function(x, language = get_locale(), ...) {
#' @export
mo_gramstain <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_gramstain")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_gramstain")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -376,8 +376,8 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
#' @export
mo_is_gram_negative <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_is_gram_negative")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_gram_negative")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -395,8 +395,8 @@ mo_is_gram_negative <- function(x, language = get_locale(), ...) {
#' @export
mo_is_gram_positive <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_is_gram_positive")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_gram_positive")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -414,8 +414,8 @@ mo_is_gram_positive <- function(x, language = get_locale(), ...) {
#' @export
mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_is_intrinsic_resistant")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_is_intrinsic_resistant")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(ab, allow_NA = FALSE)
@ -433,11 +433,12 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
stop_("length of `x` and `ab` must be equal, or one of them must be of length 1.")
}
# show used version number once
if (message_not_thrown_before("intrinsic_resistant_version")) {
# show used version number once per session (pkg_env will reload every session)
if (message_not_thrown_before("intrinsic_resistant_version", entire_session = TRUE)) {
message_("Determining intrinsic resistance based on ",
format_eucast_version_nr(3.2, markdown = FALSE), ".")
remember_thrown_message("intrinsic_resistant_version")
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)
@ -448,8 +449,8 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
#' @export
mo_snomed <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_snomed")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_snomed")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -461,8 +462,8 @@ mo_snomed <- function(x, language = get_locale(), ...) {
#' @export
mo_ref <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_ref")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_ref")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -474,8 +475,8 @@ mo_ref <- function(x, language = get_locale(), ...) {
#' @export
mo_authors <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_authors")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_authors")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -490,8 +491,8 @@ mo_authors <- function(x, language = get_locale(), ...) {
#' @export
mo_year <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_year")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_year")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -506,8 +507,8 @@ mo_year <- function(x, language = get_locale(), ...) {
#' @export
mo_rank <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_rank")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_rank")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -519,8 +520,8 @@ mo_rank <- function(x, language = get_locale(), ...) {
#' @export
mo_taxonomy <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_taxonomy")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_taxonomy")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -545,8 +546,8 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
#' @export
mo_synonyms <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_synonyms")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_synonyms")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -578,8 +579,8 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
#' @export
mo_info <- function(x, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_info")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_info")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
@ -608,8 +609,8 @@ mo_info <- function(x, language = get_locale(), ...) {
#' @export
mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_url")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_url")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
@ -645,8 +646,8 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
#' @export
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (missing(x)) {
# this supports using in dplyr verbs: ... %>% filter(mo_is_intrinsic_resistant(ab = "amox"))
x <- find_mo_col("mo_property")
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_property")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
@ -700,7 +701,7 @@ mo_validate <- function(x, property, language, ...) {
}
find_mo_col <- function(fn) {
# this function tries to find an mo column using dplyr::cur_data_all() for mo_is_*() functions,
# 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) # will return an error if not found
mo <- NULL