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

(v1.5.0.9010) MDRO vignette update, get_episode for < day

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-01-24 14:48:56 +01:00
parent 1a88caa119
commit 286eaa9699
52 changed files with 319 additions and 210 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
R/aa_helper_functions.R
View File

@ -458,9 +458,9 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE) {
format_class <- function(class, plural) {
class.bak <- class
class[class %in% c("numeric", "double")] <- "number"
class[class == "numeric"] <- "number"
class[class == "integer"] <- "whole number"
if (any(c("numeric", "double") %in% class.bak, na.rm = TRUE) & "integer" %in% class.bak) {
if (all(c("numeric", "integer") %in% class.bak, na.rm = TRUE)) {
class[class %in% c("number", "whole number")] <- "(whole) number"
}
class[class == "character"] <- "text string"
@ -496,6 +496,8 @@ meet_criteria <- function(object,
has_length = NULL,
looks_like = NULL,
is_in = NULL,
is_positive = NULL,
is_finite = NULL,
contains_column_class = NULL,
allow_NULL = FALSE,
allow_NA = FALSE,
@ -504,6 +506,16 @@ meet_criteria <- function(object,
obj_name <- deparse(substitute(object))
call_depth <- -2 - abs(.call_depth)
# if object is missing, or another error:
tryCatch(invisible(object),
error = function(e) pkg_env$meet_criteria_error_txt <- e$message)
if (!is.null(pkg_env$meet_criteria_error_txt)) {
error_txt <- pkg_env$meet_criteria_error_txt
pkg_env$meet_criteria_error_txt <- NULL
stop(error_txt, call. = FALSE)
}
pkg_env$meet_criteria_error_txt <- NULL
if (is.null(object)) {
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
@ -552,6 +564,24 @@ meet_criteria <- function(object,
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
call = call_depth)
}
if (!is.null(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a positive number",
"all be positive numbers"),
" (higher than zero)",
call = call_depth)
}
if (!is.null(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ",
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)",
call = call_depth)
}
if (!is.null(contains_column_class)) {
stop_ifnot(any(vapply(FUN.VALUE = logical(1),
object,

2
R/ab_class_selectors.R
View File

@ -38,7 +38,7 @@
#' @inheritSection AMR Reference Data Publicly Available
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):

4
R/age.R
View File

@ -149,8 +149,8 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' }
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
meet_criteria(x, allow_class = c("numeric", "integer"))
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"))
meet_criteria(x, allow_class = c("numeric", "integer"), is_positive = TRUE, is_finite = TRUE)
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"), is_positive = TRUE, is_finite = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (any(x < 0, na.rm = TRUE)) {

2
R/availability.R
View File

@ -44,7 +44,7 @@
#' }
availability <- function(tbl, width = NULL) {
meet_criteria(tbl, allow_class = "data.frame")
meet_criteria(width, allow_class = "numeric", allow_NULL = TRUE)
meet_criteria(width, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
x <- vapply(FUN.VALUE = double(1), tbl, function(x) {
1 - sum(is.na(x)) / length(x)

2
R/bug_drug_combinations.R
View File

@ -129,7 +129,7 @@ format.bug_drug_combinations <- function(x,
meet_criteria(x, allow_class = "data.frame")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(add_ab_group, allow_class = "logical", has_length = 1)

2
R/disk.R
View File

@ -61,7 +61,7 @@ as.disk <- function(x, na.rm = FALSE) {
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (!is.disk(x)) {
x <- x %pm>% unlist()
x <- unlist(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}

36
R/episode.R
View File

@ -28,8 +28,8 @@
#' 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, see *Details*
#' @param ... arguments passed on to [as.Date()]
#' @param episode_days required episode length in days, can also be less than a day, see *Details*
#' @param ... arguments passed on to [as.POSIXct()]
#' @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.
#'
@ -44,15 +44,20 @@
#' @export
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' get_episode(example_isolates$date, episode_days = 60)
#' is_new_episode(example_isolates$date, episode_days = 60)
#' get_episode(example_isolates$date, episode_days = 60) # indices
#' is_new_episode(example_isolates$date, episode_days = 60) # TRUE/FALSE
#'
#' # filter on results from the third 60-day episode only, using base R
#' example_isolates[which(get_episode(example_isolates$date, 60) == 3), ]
#'
#' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(c(Sys.time(),
#' Sys.time() + 60 * 60),
#' episode_days = 1/24)
#'
#' \donttest{
#' if (require("dplyr")) {
#' # is_new_episode() can also be used in dplyr verbs to determine patient
@ -100,7 +105,9 @@
#' }
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)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
stop_if(inherits(x, "Date") & episode_days < 1,
"argument `episode_days` must be at least 1 (day) when `x` is not a date-time object")
exec_episode(type = "sequential",
x = x,
@ -112,7 +119,9 @@ get_episode <- function(x, episode_days, ...) {
#' @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)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
stop_if(inherits(x, "Date") & episode_days < 1,
"argument `episode_days` must be at least 1 (day) when `x` is not a date-time object")
exec_episode(type = "logical",
x = x,
@ -121,7 +130,10 @@ is_new_episode <- function(x, episode_days, ...) {
}
exec_episode <- function(type, x, episode_days, ...) {
x <- as.double(as.Date(x, ...)) # as.Date() for POSIX classes
x <- as.double(as.POSIXct(x, ...)) # as.POSIXct() for Date classes
# since x is now in seconds, get seconds from episode_days as well
episode_seconds <- episode_days * 60 * 60 * 24
if (length(x) == 1) {
if (type == "logical") {
return(TRUE)
@ -129,7 +141,7 @@ exec_episode <- function(type, x, episode_days, ...) {
return(1)
}
} else if (length(x) == 2) {
if (max(x) - min(x) >= episode_days) {
if (max(x) - min(x) >= episode_seconds) {
if (type == "logical") {
return(c(TRUE, TRUE))
} else if (type == "sequential") {
@ -146,13 +158,13 @@ exec_episode <- function(type, x, episode_days, ...) {
# I asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
exec <- function(x, episode_days) {
exec <- function(x, episode_seconds) {
indices <- integer()
start <- x[1]
ind <- 1
indices[1] <- 1
for (i in 2:length(x)) {
if (isTRUE((x[i] - start) >= episode_days)) {
if (isTRUE((x[i] - start) >= episode_seconds)) {
ind <- ind + 1
if (type == "logical") {
indices[ind] <- i
@ -175,7 +187,7 @@ exec_episode <- function(type, x, episode_days, ...) {
df <- data.frame(x = x,
y = seq_len(length(x))) %pm>%
pm_arrange(x)
df$new <- exec(df$x, episode_days)
df$new <- exec(df$x, episode_seconds)
df %pm>%
pm_arrange(y) %pm>%
pm_pull(new)

10
R/first_isolate.R
View File

@ -46,7 +46,7 @@
#' @param include_unknown logical to determine whether 'unknown' microorganisms should be included too, i.e. microbial code `"UNKNOWN"`, which defaults to `FALSE`. For WHONET users, this means that all records with organism code `"con"` (*contamination*) will be excluded at default. Isolates with a microbial ID of `NA` will always be excluded as first isolate.
#' @param ... arguments passed on to [first_isolate()] when using [filter_first_isolate()], or arguments passed on to [key_antibiotics()] when using [filter_first_weighted_isolate()]
#' @details
#' These functions are context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` argument can be left blank, see *Examples*.
#' These functions are context-aware. This means that then the `x` argument can be left blank, see *Examples*.
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
#'
@ -96,7 +96,7 @@
#' **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition**, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # basic filtering on first isolates
@ -172,20 +172,20 @@ first_isolate <- function(x,
col_keyantibiotics <- NULL
}
meet_criteria(col_keyantibiotics, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(testcodes_exclude, allow_class = "character", allow_NULL = TRUE)
meet_criteria(icu_exclude, allow_class = "logical", has_length = 1)
meet_criteria(specimen_group, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(type, allow_class = "character", has_length = 1)
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
dots.names <- dots %pm>% names()
dots.names <- names(dots)
if ("filter_specimen" %in% dots.names) {
specimen_group <- dots[which(dots.names == "filter_specimen")]
}

26
R/ggplot_pca.R
View File

@ -61,7 +61,7 @@
#' @rdname ggplot_pca
#' @export
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # See ?pca for more info about Principal Component Analysis (PCA).
@ -109,26 +109,26 @@ ggplot_pca <- function(x,
stop_ifnot_installed("ggplot2")
meet_criteria(x, allow_class = c("prcomp", "princomp", "PCA", "lda"))
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2)
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2, is_positive = TRUE, is_finite = TRUE)
meet_criteria(scale, allow_class = c("numeric", "integer", "logical"), has_length = 1)
meet_criteria(pc.biplot, allow_class = "logical", has_length = 1)
meet_criteria(labels, allow_class = "character", allow_NULL = TRUE)
meet_criteria(labels_textsize, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(labels_text_placement, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(labels_textsize, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(labels_text_placement, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(groups, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ellipse, allow_class = "logical", has_length = 1)
meet_criteria(ellipse_prob, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(ellipse_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(ellipse_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(ellipse_prob, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(ellipse_size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(ellipse_alpha, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(points_size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(points_alpha, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(arrows, allow_class = "logical", has_length = 1)
meet_criteria(arrows_colour, allow_class = "character", has_length = 1)
meet_criteria(arrows_size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows_textsize, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows_size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(arrows_textsize, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(arrows_textangled, allow_class = "logical", has_length = 1)
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
calculations <- pca_calculations(pca_model = x,
groups = groups,

14
R/ggplot_rsi.R
View File

@ -180,12 +180,12 @@ ggplot_rsi <- function(data,
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(colours, allow_class = c("character", "logical"))
meet_criteria(datalabels, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
meet_criteria(title, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(subtitle, allow_class = "character", has_length = 1, allow_NULL = TRUE)
@ -279,7 +279,7 @@ geom_rsi <- function(position = NULL,
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(fill, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
@ -327,7 +327,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
facet <- facet[1]
stop_ifnot_installed("ggplot2")
meet_criteria(facet, allow_class = "character", has_length = 1)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
# we work with aes_string later on
facet_deparse <- deparse(substitute(facet))
@ -414,11 +414,11 @@ labels_rsi_count <- function(position = NULL,
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
if (is.null(position)) {

10
R/key_antibiotics.R
View File

@ -27,7 +27,7 @@
#'
#' These function can be used to determine first isolates (see [first_isolate()]). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates can then be called first 'weighted' isolates.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a [data.frame] with antibiotics columns, like `AMX` or `amox`. Can be left blank when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`.
#' @param x a [data.frame] with antibiotics columns, like `AMX` or `amox`. Can be left blank to determine automatically
#' @param y,z character vectors to compare
#' @inheritParams first_isolate
#' @param universal_1,universal_2,universal_3,universal_4,universal_5,universal_6 column names of **broad-spectrum** antibiotics, case-insensitive. See details for which antibiotics will be used at default (which are guessed with [guess_ab_col()]).
@ -36,7 +36,7 @@
#' @param warnings give a warning about missing antibiotic columns (they will be ignored)
#' @param ... other arguments passed on to functions
#' @details
#' The [key_antibiotics()] function is context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` argument can be left blank, see *Examples*.
#' The [key_antibiotics()] function is context-aware. This means that then the `x` argument can be left blank, see *Examples*.
#'
#' The function [key_antibiotics()] returns a character vector with 12 antibiotic results for every isolate. These isolates can then be compared using [key_antibiotics_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`) by [key_antibiotics()] and ignored by [key_antibiotics_equal()].
#'
@ -77,7 +77,7 @@
#' @seealso [first_isolate()]
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' # output of the `key_antibiotics()` function could be like this:
@ -158,7 +158,7 @@ key_antibiotics <- function(x,
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
dots.names <- dots %pm>% names()
dots.names <- names(dots)
if ("info" %in% dots.names) {
warnings <- dots[which(dots.names == "info")]
}
@ -291,7 +291,7 @@ key_antibiotics_equal <- function(y,
meet_criteria(z, allow_class = "character")
meet_criteria(type, allow_class = "character", has_length = c(1, 2))
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
stop_ifnot(length(y) == length(z), "length of `y` and `z` must be equal")

4
R/mdro.R
View File

@ -37,7 +37,7 @@
#' @param verbose a logical to turn Verbose mode on and off (default is off). In Verbose mode, the function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.
#' @inheritSection eucast_rules Antibiotics
#' @details
#' These functions are context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` argument can be left blank, see *Examples*.
#' These functions are context-aware. This means that then the `x` argument can be left blank, see *Examples*.
#'
#' For the `pct_required_classes` argument, values above 1 will be divided by 100. This is to support both fractions (`0.75` or `3/4`) and percentages (`75`).
#'
@ -108,7 +108,7 @@
#' #> 43 891 1066
#' ```
#'
#' The rules set (the `custom` object in this case) could be exported to a shared file location using [saveRDS()] if you collaborate with multiple users. The custom rules set could then be imported using [readRDS()],
#' The rules set (the `custom` object in this case) could be exported to a shared file location using [saveRDS()] if you collaborate with multiple users. The custom rules set could then be imported using [readRDS()].
#' @inheritSection as.rsi Interpretation of R and S/I
#' @return
#' - CMI 2012 paper - function [mdr_cmi2012()] or [mdro()]:\cr

2
R/mic.R
View File

@ -62,7 +62,7 @@ as.mic <- function(x, na.rm = FALSE) {
if (is.mic(x)) {
x
} else {
x <- x %pm>% unlist()
x <- unlist(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}

2
R/mo.R
View File

@ -1546,7 +1546,7 @@ exec_as.mo <- function(x,
message_(word_wrap("- Try to use as many valid taxonomic names as possible for your input.",
extra_indent = 2),
as_note = FALSE)
message_(word_wrap("- Save the output and use it as input for future calculations, e.g. create a new variable to your data using `as.mo()`. All functions in this package that rely on microorganism codes will automatically use that new column where possible. All `mo_*()` functions also do not require you to set their `x` argument as long as you have the dplyr package installed and you have a column of class <mo>.",
message_(word_wrap("- Save the output and use it as input for future calculations, e.g. create a new variable to your data using `as.mo()`. All functions in this package that rely on microorganism codes will automatically use that new column where possible. All `mo_*()` functions also do not require you to set their `x` argument as long as you have a column of class <mo>.",
extra_indent = 2),
as_note = FALSE)
message_(word_wrap("- Use `set_mo_source()` to continually transform your organisation codes to microorganisms codes used by this package, see `?mo_source`.",

4
R/mo_source.R
View File

@ -200,8 +200,8 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
"', for which your permission is needed.")),
"\n\n",
word_wrap("Do you agree that this file will be created?"))
if ("rsasdtudioapi" %in% rownames(utils::installed.packages())) {
showQuestion <- import_fn("showQuestion", "rstudioapi")
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Create new file in home directory", txt)
} else {
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)

2
R/pca.R
View File

@ -38,7 +38,7 @@
#' @export
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # `example_isolates` is a dataset available in the AMR package.
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' \donttest{

10
R/resistance_predict.R
View File

@ -129,10 +129,10 @@ resistance_predict <- function(x,
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_ab, allow_class = "character", has_length = 1, is_in = colnames(x))
meet_criteria(col_date, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(year_min, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(year_max, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE)
meet_criteria(year_every, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(year_min, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(year_max, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(year_every, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(model, allow_class = c("character", "function"), has_length = 1, allow_NULL = TRUE)
meet_criteria(I_as_S, allow_class = "logical", has_length = 1)
meet_criteria(preserve_measurements, allow_class = "logical", has_length = 1)
@ -143,7 +143,7 @@ resistance_predict <- function(x,
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
dots.names <- dots %pm>% names()
dots.names <- names(dots)
if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == "tbl")]
}

6
R/rsi.R
View File

@ -29,7 +29,7 @@
#' @inheritSection lifecycle Stable Lifecycle
#' @rdname as.rsi
#' @param x vector of values (for class [`mic`]: an MIC value in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()], will be determined automatically if the `dplyr` package is installed
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()], can be left empty to determine it automatically
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial code with [as.ab()]
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a 'specimen' and rows containing 'urin' (such as 'urine', 'urina') in that column will be regarded isolates from a UTI. See *Examples*.
#' @inheritParams first_isolate
@ -479,7 +479,7 @@ as.rsi.data.frame <- function(x,
uti = NULL,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = rsi_translation) {
reference_data = AMR::rsi_translation) {
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
@ -994,7 +994,7 @@ plot.rsi <- function(x,
main = paste("Resistance Overview of", deparse(substitute(x))),
axes = FALSE,
...) {
meet_criteria(lwd, allow_class = c("numeric", "integer"), has_length = 1)
meet_criteria(lwd, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(ylim, allow_class = c("numeric", "integer"), allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)

4
R/rsi_calc.R
View File

@ -37,7 +37,7 @@ rsi_calc <- function(...,
only_all_tested = FALSE,
only_count = FALSE) {
meet_criteria(ab_result, allow_class = c("character", "numeric", "integer"), has_length = c(1, 2, 3), .call_depth = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, .call_depth = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, .call_depth = 1)
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(only_count, allow_class = "logical", has_length = 1, .call_depth = 1)
@ -191,7 +191,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi", .call_depth = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE, .call_depth = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, .call_depth = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, .call_depth = 1)
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(combine_SI_missing, allow_class = "logical", has_length = 1, .call_depth = 1)