mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 10:21:49 +02:00
(v.1.5.0.9000) implementation of EUCAST rules v11 (2021)
This commit is contained in:
@ -81,10 +81,13 @@ check_dataset_integrity <- function() {
|
||||
overwritten <- data_in_pkg[data_in_pkg %in% data_in_globalenv]
|
||||
# exception for example_isolates
|
||||
overwritten <- overwritten[overwritten != "example_isolates"]
|
||||
stop_if(length(overwritten) > 0,
|
||||
"the following data set is overwritten by your global environment and prevents the AMR package from working correctly:\n",
|
||||
paste0("'", overwritten, "'", collapse = ", "),
|
||||
".\nPlease rename your object before using this function.", call = FALSE)
|
||||
if (length(overwritten) > 0) {
|
||||
warning_(ifelse(length(overwritten) == 1,
|
||||
"The following data set is overwritten by your global environment and prevents the AMR package from working correctly: ",
|
||||
"The following data sets are overwritten by your global environment and prevent the AMR package from working correctly: "),
|
||||
paste0("'", overwritten, "'", collapse = ", "),
|
||||
".\nPlease rename your object(s).", call = FALSE)
|
||||
}
|
||||
# check if other packages did not overwrite our data sets
|
||||
tryCatch({
|
||||
check_microorganisms <- all(c("mo", "fullname", "kingdom", "phylum",
|
||||
@ -439,6 +442,20 @@ create_ab_documentation <- function(ab) {
|
||||
out
|
||||
}
|
||||
|
||||
vector_or <- function(v, quotes = TRUE, reverse = FALSE) {
|
||||
# makes unique and sorts, and this also removed NAs
|
||||
v <- sort(unique(v))
|
||||
if (length(v) == 1) {
|
||||
return(paste0(ifelse(quotes, '"', ""), v, ifelse(quotes, '"', "")))
|
||||
}
|
||||
if (reverse == TRUE) {
|
||||
v <- rev(v)
|
||||
}
|
||||
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
|
||||
paste0(paste0(ifelse(quotes, '"', ""), v[seq_len(length(v) - 1)], ifelse(quotes, '"', ""), collapse = ", "),
|
||||
" or ", paste0(ifelse(quotes, '"', ""), v[length(v)], ifelse(quotes, '"', "")))
|
||||
}
|
||||
|
||||
# a check for every single argument in all functions
|
||||
meet_criteria <- function(object,
|
||||
allow_class = NULL,
|
||||
@ -463,15 +480,6 @@ meet_criteria <- function(object,
|
||||
return(invisible())
|
||||
}
|
||||
|
||||
vector_or <- function(v, quotes) {
|
||||
if (length(v) == 1) {
|
||||
return(paste0(ifelse(quotes, '"', ""), v, ifelse(quotes, '"', "")))
|
||||
}
|
||||
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
|
||||
paste0(paste0(ifelse(quotes, '"', ""), v[seq_len(length(v) - 1)], ifelse(quotes, '"', ""), collapse = ", "),
|
||||
" or ", paste0(ifelse(quotes, '"', ""), v[length(v)], ifelse(quotes, '"', "")))
|
||||
}
|
||||
|
||||
if (!is.null(allow_class)) {
|
||||
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
|
||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||
@ -527,24 +535,38 @@ meet_criteria <- function(object,
|
||||
}
|
||||
|
||||
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
|
||||
cur_data_all <- import_fn("cur_data_all", "dplyr", error_on_fail = FALSE)
|
||||
if (!is.null(cur_data_all)) {
|
||||
out <- tryCatch(cur_data_all(), error = function(e) NULL)
|
||||
if (is.data.frame(out)) {
|
||||
return(out)
|
||||
}
|
||||
}
|
||||
|
||||
if (as.double(R.Version()$major) + (as.double(R.Version()$minor) / 10) < 3.2) {
|
||||
# R-3.0 and R-3.1 do not have an `x` element in the call stack, rendering this function useless
|
||||
if (is.na(arg_name)) {
|
||||
# like in carbapenems() etc.
|
||||
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 (".Generic" %in% names(el)) {
|
||||
if (tryCatch(not_set == TRUE && ".data" %in% names(el) && is.data.frame(el$`.data`), error = function(e) FALSE)) {
|
||||
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
|
||||
# will be used in dplyr::select() (but not in dplyr::filter(), dplyr::mutate() or dplyr::summarise())
|
||||
not_set <<- FALSE
|
||||
el$`.data`
|
||||
} else if (tryCatch(not_set == TRUE && any(c("x", "xx") %in% names(el)), error = function(e) FALSE)) {
|
||||
} else if (tryCatch(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()]`
|
||||
@ -574,9 +596,7 @@ get_current_data <- function(arg_name, call) {
|
||||
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)
|
||||
stop_("argument `", arg_name, "` is missing with no default", call = call)
|
||||
}
|
||||
}
|
||||
|
||||
@ -595,19 +615,19 @@ unique_call_id <- function(entire_session = FALSE) {
|
||||
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("thrown_msg_", fn),
|
||||
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))
|
||||
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% "^thrown_msg_"],
|
||||
rm(list = pkg_env_contents[pkg_env_contents %like% "^thrown_msg."],
|
||||
envir = pkg_env)
|
||||
}
|
||||
|
||||
|
Reference in New Issue
Block a user