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

(v1.4.0.9059) ab class selector fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-01-04 12:29:25 +01:00
parent 82cfa24ea4
commit c9de74c81a
17 changed files with 64 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
R/aa_helper_functions.R
View File

@ -458,7 +458,7 @@ meet_criteria <- function(object,
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
return(invisible())
}
if (is.null(dim(object)) && length(object) == 1 && is.na(object)) {
if (is.null(dim(object)) && length(object) == 1 && suppressWarnings(is.na(object))) { # suppressWarnings for functions
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
return(invisible())
}
@ -527,23 +527,36 @@ meet_criteria <- function(object,
}
get_current_data <- function(arg_name, call) {
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 100) < 3.2) {
if (is.na(arg_name)) {
warning_("this function can only be used in R >= 3.2", call = call)
return(data.frame())
} else {
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)) {
if (".Generic" %in% names(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$xx
} else if (is.data.frame(el$x)) {
not_set <<- FALSE
el$x
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 (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
}

11
R/ab_class_selectors.R
View File

@ -27,7 +27,9 @@
#'
#' These functions help to select the columns of antibiotics that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
#' @inheritParams filter_ab_class
#' @details All columns 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 like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#' @details These functions only work in R 3.2 (2015) and later.
#'
#' All columns 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 like e.g. [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#' @rdname antibiotic_class_selectors
#' @seealso [filter_ab_class()] for the `filter()` equivalent.
#' @name antibiotic_class_selectors
@ -161,7 +163,12 @@ 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)
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 100) < 3.2) {
warning_(function_name, "() can only be used in R >= 3.2", call = FALSE)
return(NULL)
}
vars_df <- get_current_data(arg_name = NA, call = -3)
ab_in_data <- get_column_abx(vars_df, info = FALSE)