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

(v1.4.0.9046) get_episode

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-12-27 00:07:00 +01:00
parent 291f802be3
commit acbd0cf7ca
99 changed files with 1143 additions and 683 deletions
Download Patch File Download Diff File Expand all files Collapse all files

54
R/aa_helper_functions.R
View File

@ -536,22 +536,39 @@ get_current_data <- function(arg_name, call) {
call = call - 4))
}
get_root_env_address <- function() {
sub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]))
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 = ""))
}
remember_thrown_message <- function(fn) {
assign(x = paste0("address_", fn),
value = get_root_env_address(),
envir = mo_env)
# 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(),
envir = pkg_env)
}
message_not_thrown_before <- function(fn) {
is.null(mo_env[[paste0("address_", fn)]]) || !identical(mo_env[[paste0("address_", fn)]], get_root_env_address())
is.null(pkg_env[[paste0("uniquecall_", fn)]]) || !identical(pkg_env[[paste0("uniquecall_", fn)]], unique_call_id())
}
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_"],
envir = pkg_env)
}
has_colour <- function() {
# this is a base R version of crayon::has_color
# 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
return(FALSE)
}
enabled <- getOption("crayon.enabled")
if (!is.null(enabled)) {
return(isTRUE(enabled))
@ -581,20 +598,6 @@ has_colour <- function() {
}
return(FALSE)
}
emacs_version <- function() {
ver <- Sys.getenv("INSIDE_EMACS")
if (ver == "") {
return(NA_integer_)
}
ver <- gsub("'", "", ver)
ver <- strsplit(ver, ",", fixed = TRUE)[[1]]
ver <- strsplit(ver, ".", fixed = TRUE)[[1]]
as.numeric(ver)
}
if ((Sys.getenv("EMACS") != "" || Sys.getenv("INSIDE_EMACS") != "") &&
!is.na(emacs_version()[1]) && emacs_version()[1] >= 23) {
return(TRUE)
}
if ("COLORTERM" %in% names(Sys.getenv())) {
return(TRUE)
}
@ -656,6 +659,15 @@ font_grey_bg <- function(..., collapse = " ") {
font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_rsi_R_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;202m", after = "\033[49m", collapse = collapse)
}
font_rsi_S_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;76m", after = "\033[49m", collapse = collapse)
}
font_rsi_I_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;148m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)
}

90
R/is_new_episode.R → R/episode.R
View File

@ -25,26 +25,34 @@
#' Determine (new) episodes for patients
#'
#' This function determines which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis.
#' These functions determine which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis. The [get_episode()] function returns the index number of the episode per group, while the [is_new_episode()] function returns values `TRUE`/`FALSE` to indicate whether an item in a vector is the start of a new episode.
#' @inheritSection lifecycle Stable lifecycle
#' @param x vector of dates (class `Date` or `POSIXt`)
#' @param episode_days length of the required episode in days, defaults to 365. Every element in the input will return `TRUE` after this number of days has passed since the last included date, independent of calendar years. Please see *Details*.
#' @param episode_days length of the required episode in days, please see *Details*
#' @param ... arguments passed on to [as.Date()]
#' @details
#' Dates are first sorted from old to new. The oldest date will mark the start of the first episode. After this date, the next date will be marked that is at least `episode_days` days later than the start of the first episode. From that second marked date on, the next date will be marked that is at least `episode_days` days later than the start of the second episode which will be the start of the third episode, and so on. Before the vector is being returned, the original order will be restored.
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but is more efficient for data sets containing microorganism codes or names.
#'
#' The `dplyr` package is not required for this function to work, but this function works conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
#' @return a [logical] vector
#' The `dplyr` package is not required for these functions to work, but these functions support [variable grouping][dplyr::group_by()] and work conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
#' @return
#' * [get_episode()]: a [double] vector
#' * [is_new_episode()]: a [logical] vector
#' @seealso [first_isolate()]
#' @rdname get_episode
#' @export
#' @inheritSection AMR Read more on our website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # See ?example_isolates.
#'
#' is_new_episode(example_isolates$date)
#' get_episode(example_isolates$date, episode_days = 60)
#' is_new_episode(example_isolates$date, episode_days = 60)
#'
#' # filter on results from the third 60-day episode using base R
#' example_isolates[which(get_episode(example_isolates$date, 60) == 3), ]
#'
#' \donttest{
#' if (require("dplyr")) {
#' # is_new_episode() can also be used in dplyr verbs to determine patient
@ -54,7 +62,15 @@
#' size = 2000,
#' replace = TRUE)) %>%
#' group_by(condition) %>%
#' mutate(new_episode = is_new_episode(date))
#' mutate(new_episode = is_new_episode(date, 365))
#'
#' example_isolates %>%
#' group_by(hospital_id, patient_id) %>%
#' transmute(date,
#' patient_id,
#' new_index = get_episode(date, 60),
#' new_logical = is_new_episode(date, 60))
#'
#'
#' example_isolates %>%
#' group_by(hospital_id) %>%
@ -71,7 +87,7 @@
#'
#' y <- example_isolates %>%
#' group_by(patient_id, mo) %>%
#' filter(is_new_episode(date))
#' filter(is_new_episode(date, 365))
#'
#' identical(x$patient_id, y$patient_id)
#'
@ -79,21 +95,52 @@
#' # since you can now group on anything that seems relevant:
#' example_isolates %>%
#' group_by(patient_id, mo, hospital_id, ward_icu) %>%
#' mutate(flag_episode = is_new_episode(date))
#' mutate(flag_episode = is_new_episode(date, 365))
#' }
#' }
is_new_episode <- function(x, episode_days = 365, ...) {
get_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"))
meet_criteria(episode_days, allow_class = c("numeric", "double", "integer"), has_length = 1)
exec_episode(type = "sequential",
x = x,
episode_days = episode_days,
... = ...)
}
#' @rdname get_episode
#' @export
is_new_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"))
meet_criteria(episode_days, allow_class = c("numeric", "double", "integer"), has_length = 1)
exec_episode(type = "logical",
x = x,
episode_days = episode_days,
... = ...)
}
exec_episode <- function(type, x, episode_days, ...) {
x <- as.double(as.Date(x, ...)) # as.Date() for POSIX classes
if (length(x) == 1) {
return(TRUE)
if (type == "logical") {
return(TRUE)
} else if (type == "sequential") {
return(1)
}
} else if (length(x) == 2) {
if (max(x) - min(x) >= episode_days) {
return(c(TRUE, TRUE))
if (type == "logical") {
return(c(TRUE, TRUE))
} else if (type == "sequential") {
return(c(1, 2))
}
} else {
return(c(TRUE, FALSE))
if (type == "logical") {
return(c(TRUE, FALSE))
} else if (type == "sequential") {
return(c(1, 1))
}
}
}
@ -107,13 +154,22 @@ is_new_episode <- function(x, episode_days = 365, ...) {
for (i in 2:length(x)) {
if (isTRUE((x[i] - start) >= episode_days)) {
ind <- ind + 1
indices[ind] <- i
if (type == "logical") {
indices[ind] <- i
}
start <- x[i]
}
if (type == "sequential") {
indices[i] <- ind
}
}
if (type == "logical") {
result <- rep(FALSE, length(x))
result[indices] <- TRUE
result
} else if (type == "sequential") {
indices
}
result <- rep(FALSE, length(x))
result[indices] <- TRUE
result
}
df <- data.frame(x = x,

58
R/mo.R
View File

@ -361,11 +361,11 @@ exec_as.mo <- function(x,
# keep track of time - give some hints to improve speed if it takes a long time
start_time <- Sys.time()
mo_env$mo_failures <- NULL
mo_env$mo_uncertainties <- NULL
mo_env$mo_renamed <- NULL
pkg_env$mo_failures <- NULL
pkg_env$mo_uncertainties <- NULL
pkg_env$mo_renamed <- NULL
}
mo_env$mo_renamed_last_run <- NULL
pkg_env$mo_renamed_last_run <- NULL
failures <- character(0)
uncertainty_level <- translate_allow_uncertain(allow_uncertain)
@ -598,7 +598,7 @@ exec_as.mo <- function(x,
} else {
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
mo_env$mo_renamed_last_run <- found["fullname"]
pkg_env$mo_renamed_last_run <- found["fullname"]
was_renamed(name_old = found["fullname"],
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
@ -973,7 +973,7 @@ exec_as.mo <- function(x,
} else {
x[i] <- lookup(fullname == found["fullname_new"], haystack = MO_lookup)
}
mo_env$mo_renamed_last_run <- found["fullname"]
pkg_env$mo_renamed_last_run <- found["fullname"]
was_renamed(name_old = found["fullname"],
name_new = lookup(fullname == found["fullname_new"], "fullname", haystack = MO_lookup),
ref_old = found["ref"],
@ -1025,7 +1025,7 @@ exec_as.mo <- function(x,
ref_old = found["ref"],
ref_new = lookup(fullname == found["fullname_new"], "ref", haystack = MO_lookup),
mo = lookup(fullname == found["fullname_new"], "mo", haystack = MO_lookup))
mo_env$mo_renamed_last_run <- found["fullname"]
pkg_env$mo_renamed_last_run <- found["fullname"]
uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
@ -1396,7 +1396,7 @@ exec_as.mo <- function(x,
# handling failures ----
failures <- failures[!failures %in% c(NA, NULL, NaN)]
if (length(failures) > 0 & initial_search == TRUE) {
mo_env$mo_failures <- sort(unique(failures))
pkg_env$mo_failures <- sort(unique(failures))
plural <- c("value", "it", "was")
if (pm_n_distinct(failures) > 1) {
plural <- c("values", "them", "were")
@ -1423,7 +1423,7 @@ exec_as.mo <- function(x,
# handling uncertainties ----
if (NROW(uncertainties) > 0 & initial_search == TRUE) {
uncertainties <- as.list(pm_distinct(uncertainties, input, .keep_all = TRUE))
mo_env$mo_uncertainties <- uncertainties
pkg_env$mo_uncertainties <- uncertainties
plural <- c("", "it", "was")
if (length(uncertainties$input) > 1) {
@ -1559,13 +1559,13 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "")
new_ref = ref_new,
mo = mo,
stringsAsFactors = FALSE)
already_set <- mo_env$mo_renamed
already_set <- pkg_env$mo_renamed
if (!is.null(already_set)) {
mo_env$mo_renamed = rbind(already_set,
pkg_env$mo_renamed = rbind(already_set,
newly_set,
stringsAsFactors = FALSE)
} else {
mo_env$mo_renamed <- newly_set
pkg_env$mo_renamed <- newly_set
}
}
@ -1573,9 +1573,9 @@ format_uncertainty_as_df <- function(uncertainty_level,
input,
result_mo,
candidates = NULL) {
if (!is.null(mo_env$mo_renamed_last_run)) {
fullname <- mo_env$mo_renamed_last_run
mo_env$mo_renamed_last_run <- NULL
if (!is.null(pkg_env$mo_renamed_last_run)) {
fullname <- pkg_env$mo_renamed_last_run
pkg_env$mo_renamed_last_run <- NULL
renamed_to <- MO_lookup[match(result_mo, MO_lookup$mo), "fullname", drop = TRUE][1]
} else {
fullname <- MO_lookup[match(result_mo, MO_lookup$mo), "fullname", drop = TRUE][1]
@ -1764,16 +1764,16 @@ unique.mo <- function(x, incomparables = FALSE, ...) {
#' @rdname as.mo
#' @export
mo_failures <- function() {
mo_env$mo_failures
pkg_env$mo_failures
}
#' @rdname as.mo
#' @export
mo_uncertainties <- function() {
if (is.null(mo_env$mo_uncertainties)) {
if (is.null(pkg_env$mo_uncertainties)) {
return(NULL)
}
set_clean_class(as.data.frame(mo_env$mo_uncertainties,
set_clean_class(as.data.frame(pkg_env$mo_uncertainties,
stringsAsFactors = FALSE),
new_class = c("mo_uncertainties", "data.frame"))
}
@ -1842,7 +1842,7 @@ print.mo_uncertainties <- function(x, ...) {
#' @rdname as.mo
#' @export
mo_renamed <- function() {
items <- mo_env$mo_renamed
items <- pkg_env$mo_renamed
if (is.null(items)) {
items <- data.frame(stringsAsFactors = FALSE)
} else {
@ -1906,20 +1906,20 @@ translate_allow_uncertain <- function(allow_uncertain) {
}
get_mo_failures_uncertainties_renamed <- function() {
remember <- list(failures = mo_env$mo_failures,
uncertainties = mo_env$mo_uncertainties,
renamed = mo_env$mo_renamed)
remember <- list(failures = pkg_env$mo_failures,
uncertainties = pkg_env$mo_uncertainties,
renamed = pkg_env$mo_renamed)
# empty them, otherwise mo_shortname("Chlamydophila psittaci") will give 3 notes
mo_env$mo_failures <- NULL
mo_env$mo_uncertainties <- NULL
mo_env$mo_renamed <- NULL
pkg_env$mo_failures <- NULL
pkg_env$mo_uncertainties <- NULL
pkg_env$mo_renamed <- NULL
remember
}
load_mo_failures_uncertainties_renamed <- function(metadata) {
mo_env$mo_failures <- metadata$failures
mo_env$mo_uncertainties <- metadata$uncertainties
mo_env$mo_renamed <- metadata$renamed
pkg_env$mo_failures <- metadata$failures
pkg_env$mo_uncertainties <- metadata$uncertainties
pkg_env$mo_renamed <- metadata$renamed
}
trimws2 <- function(x) {
@ -2007,4 +2007,4 @@ repair_reference_df <- function(reference_df) {
reference_df
}
mo_env <- new.env(hash = FALSE)
pkg_env <- new.env(hash = FALSE)

48
R/mo_property.R
View File

@ -163,7 +163,7 @@
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -180,7 +180,7 @@ mo_fullname <- mo_name
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -218,7 +218,7 @@ mo_shortname <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -231,7 +231,7 @@ mo_subspecies <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -244,7 +244,7 @@ mo_species <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -257,7 +257,7 @@ mo_genus <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -270,7 +270,7 @@ mo_family <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -283,7 +283,7 @@ mo_order <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -296,7 +296,7 @@ mo_class <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -309,7 +309,7 @@ mo_phylum <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -326,7 +326,7 @@ mo_domain <- mo_kingdom
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -339,7 +339,7 @@ mo_type <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -377,7 +377,7 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
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_intrinsic_resistant")
x <- find_mo_col("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)
@ -396,7 +396,7 @@ mo_is_gram_negative <- function(x, language = get_locale(), ...) {
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_intrinsic_resistant")
x <- find_mo_col("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)
@ -450,7 +450,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -463,7 +463,7 @@ mo_snomed <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -476,7 +476,7 @@ mo_ref <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -492,7 +492,7 @@ mo_authors <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -508,7 +508,7 @@ mo_year <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -521,7 +521,7 @@ mo_rank <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -547,7 +547,7 @@ mo_taxonomy <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -580,7 +580,7 @@ mo_synonyms <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("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)
@ -610,7 +610,7 @@ mo_info <- function(x, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("mo_url")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
@ -647,7 +647,7 @@ mo_url <- function(x, open = FALSE, language = get_locale(), ...) {
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_is_intrinsic_resistant")
x <- find_mo_col("mo_property")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))

18
R/mo_source.R
View File

@ -132,7 +132,7 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
stop_ifnot(interactive(), "this function can only be used in interactive mode, since it must ask for the user's permission to write a file to their home folder.")
if (is.null(path) || path %in% c(FALSE, "")) {
mo_env$mo_source <- NULL
pkg_env$mo_source <- NULL
if (file.exists(mo_source_destination)) {
unlink(mo_source_destination)
message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
@ -214,7 +214,7 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
attr(df, "mo_source_destination") <- mo_source_destination
attr(df, "mo_source_timestamp") <- file.mtime(path)
saveRDS(df, mo_source_destination)
mo_env$mo_source <- df
pkg_env$mo_source <- df
message_(action, " mo_source file '", font_bold(mo_source_destination),
"' (", formatted_filesize(mo_source_destination),
") from '", font_bold(path),
@ -232,17 +232,17 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
}
return(NULL)
}
if (is.null(mo_env$mo_source)) {
mo_env$mo_source <- readRDS(path.expand(destination))
if (is.null(pkg_env$mo_source)) {
pkg_env$mo_source <- readRDS(path.expand(destination))
}
old_time <- attributes(mo_env$mo_source)$mo_source_timestamp
new_time <- file.mtime(attributes(mo_env$mo_source)$mo_source_location)
old_time <- attributes(pkg_env$mo_source)$mo_source_timestamp
new_time <- file.mtime(attributes(pkg_env$mo_source)$mo_source_location)
if (interactive() && !identical(old_time, new_time)) {
# source file was updated, also update reference
set_mo_source(attributes(mo_env$mo_source)$mo_source_location)
set_mo_source(attributes(pkg_env$mo_source)$mo_source_location)
}
mo_env$mo_source
pkg_env$mo_source
}
check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
@ -251,7 +251,7 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}
if (is.null(mo_env$mo_source) && (identical(x, get_mo_source()))) {
if (is.null(pkg_env$mo_source) && (identical(x, get_mo_source()))) {
return(TRUE)
}
if (is.null(x)) {

6
R/rsi.R
View File

@ -844,9 +844,9 @@ exec_as.rsi <- function(method,
pillar_shaft.rsi <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- font_grey(" NA")
out[x == "S"] <- font_green_bg(font_white(" S "))
out[x == "I"] <- font_yellow_bg(font_black(" I "))
out[x == "R"] <- font_red_bg(font_white(" R "))
out[x == "R"] <- font_rsi_R_bg(font_black(" R "))
out[x == "S"] <- font_rsi_S_bg(font_black(" S "))
out[x == "I"] <- font_rsi_I_bg(font_black(" I "))
create_pillar_column(out, align = "left", width = 5)
}

6
R/rsi_calc.R
View File

@ -147,12 +147,10 @@ rsi_calc <- function(...,
}
if (print_warning == TRUE) {
# since rsi_calc() is always called from a count() or proportion() function, we use -1:
cll <- gsub("[^a-zA-Z0-9_]+", "_", paste(deparse(sys.calls()[[length(sys.calls()) - 1]]), collapse = ""))
if (message_not_thrown_before(cll)) {
if (message_not_thrown_before("rsi_calc")) {
warning_("Increase speed by transforming to class <rsi> on beforehand: your_data %>% mutate_if(is.rsi.eligible, as.rsi)",
call = FALSE)
remember_thrown_message(cll)
remember_thrown_message("rsi_calc")
}
}