support for old rsi arguments

This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-03-11 14:24:34 +01:00
parent 4416394e10
commit 262598b8d7
21 changed files with 327 additions and 199 deletions

View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.8.2.9147 Version: 1.8.2.9148
Date: 2023-02-26 Date: 2023-03-11
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9147 # AMR 1.8.2.9148
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)* *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*

View File

@ -757,7 +757,7 @@ format_class <- function(class, plural = FALSE) {
} }
# a check for every single argument in all functions # a check for every single argument in all functions
meet_criteria <- function(object, meet_criteria <- function(object, # can be literally `list(...)` for `allow_arguments_from`
allow_class = NULL, allow_class = NULL,
has_length = NULL, has_length = NULL,
looks_like = NULL, looks_like = NULL,
@ -769,6 +769,7 @@ meet_criteria <- function(object,
allow_NULL = FALSE, allow_NULL = FALSE,
allow_NA = FALSE, allow_NA = FALSE,
ignore.case = FALSE, ignore.case = FALSE,
allow_arguments_from = NULL, # 1 function, or a list of functions
.call_depth = 0) { # depth in calling .call_depth = 0) { # depth in calling
obj_name <- deparse(substitute(object)) obj_name <- deparse(substitute(object))
@ -886,6 +887,24 @@ meet_criteria <- function(object,
call = call_depth call = call_depth
) )
} }
if (!is.null(allow_arguments_from) && !is.null(names(object))) {
args_given <- names(object)
if (is.function(allow_arguments_from)) {
allow_arguments_from <- list(allow_arguments_from)
}
args_allowed <- sort(unique(unlist(lapply(allow_arguments_from, function(x) names(formals(x))))))
args_allowed <- args_allowed[args_allowed != "..."]
disallowed <- args_given[!args_given %in% args_allowed]
stop_if(length(disallowed) > 0,
ifelse(length(disallowed) == 1,
paste("the argument", vector_and(disallowed), "is"),
paste("the arguments", vector_and(disallowed), "are")
),
" not valid. Valid arguments are: ",
vector_and(args_allowed), ".",
call = call_depth
)
}
return(invisible()) return(invisible())
} }

View File

@ -181,6 +181,10 @@ ab_class <- function(ab_class,
meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec(NULL, only_sir_columns = only_sir_columns, ab_class_args = ab_class, only_treatable = only_treatable) ab_select_exec(NULL, only_sir_columns = only_sir_columns, ab_class_args = ab_class, only_treatable = only_treatable)
} }
@ -193,6 +197,10 @@ ab_selector <- function(filter,
...) { ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call # get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
# but it only takes a couple of milliseconds # but it only takes a couple of milliseconds
@ -224,6 +232,10 @@ ab_selector <- function(filter,
aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) { aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("aminoglycosides", only_sir_columns = only_sir_columns, only_treatable = only_treatable) ab_select_exec("aminoglycosides", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
} }
@ -231,6 +243,10 @@ aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...
#' @export #' @export
aminopenicillins <- function(only_sir_columns = FALSE, ...) { aminopenicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("aminopenicillins", only_sir_columns = only_sir_columns) ab_select_exec("aminopenicillins", only_sir_columns = only_sir_columns)
} }
@ -238,6 +254,10 @@ aminopenicillins <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
antifungals <- function(only_sir_columns = FALSE, ...) { antifungals <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("antifungals", only_sir_columns = only_sir_columns) ab_select_exec("antifungals", only_sir_columns = only_sir_columns)
} }
@ -245,6 +265,10 @@ antifungals <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
antimycobacterials <- function(only_sir_columns = FALSE, ...) { antimycobacterials <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("antimycobacterials", only_sir_columns = only_sir_columns) ab_select_exec("antimycobacterials", only_sir_columns = only_sir_columns)
} }
@ -253,6 +277,10 @@ antimycobacterials <- function(only_sir_columns = FALSE, ...) {
betalactams <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) { betalactams <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("betalactams", only_sir_columns = only_sir_columns, only_treatable = only_treatable) ab_select_exec("betalactams", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
} }
@ -261,6 +289,10 @@ betalactams <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
carbapenems <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) { carbapenems <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("carbapenems", only_sir_columns = only_sir_columns, only_treatable = only_treatable) ab_select_exec("carbapenems", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
} }
@ -268,6 +300,10 @@ carbapenems <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
#' @export #' @export
cephalosporins <- function(only_sir_columns = FALSE, ...) { cephalosporins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins", only_sir_columns = only_sir_columns)
} }
@ -275,6 +311,10 @@ cephalosporins <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
cephalosporins_1st <- function(only_sir_columns = FALSE, ...) { cephalosporins_1st <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins_1st", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins_1st", only_sir_columns = only_sir_columns)
} }
@ -282,6 +322,10 @@ cephalosporins_1st <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
cephalosporins_2nd <- function(only_sir_columns = FALSE, ...) { cephalosporins_2nd <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins_2nd", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins_2nd", only_sir_columns = only_sir_columns)
} }
@ -289,6 +333,10 @@ cephalosporins_2nd <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
cephalosporins_3rd <- function(only_sir_columns = FALSE, ...) { cephalosporins_3rd <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins_3rd", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins_3rd", only_sir_columns = only_sir_columns)
} }
@ -296,6 +344,10 @@ cephalosporins_3rd <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
cephalosporins_4th <- function(only_sir_columns = FALSE, ...) { cephalosporins_4th <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins_4th", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins_4th", only_sir_columns = only_sir_columns)
} }
@ -303,6 +355,10 @@ cephalosporins_4th <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
cephalosporins_5th <- function(only_sir_columns = FALSE, ...) { cephalosporins_5th <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("cephalosporins_5th", only_sir_columns = only_sir_columns) ab_select_exec("cephalosporins_5th", only_sir_columns = only_sir_columns)
} }
@ -310,6 +366,10 @@ cephalosporins_5th <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
fluoroquinolones <- function(only_sir_columns = FALSE, ...) { fluoroquinolones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("fluoroquinolones", only_sir_columns = only_sir_columns) ab_select_exec("fluoroquinolones", only_sir_columns = only_sir_columns)
} }
@ -317,6 +377,10 @@ fluoroquinolones <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
glycopeptides <- function(only_sir_columns = FALSE, ...) { glycopeptides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("glycopeptides", only_sir_columns = only_sir_columns) ab_select_exec("glycopeptides", only_sir_columns = only_sir_columns)
} }
@ -324,6 +388,10 @@ glycopeptides <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
lincosamides <- function(only_sir_columns = FALSE, ...) { lincosamides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("lincosamides", only_sir_columns = only_sir_columns) ab_select_exec("lincosamides", only_sir_columns = only_sir_columns)
} }
@ -331,6 +399,10 @@ lincosamides <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
lipoglycopeptides <- function(only_sir_columns = FALSE, ...) { lipoglycopeptides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("lipoglycopeptides", only_sir_columns = only_sir_columns) ab_select_exec("lipoglycopeptides", only_sir_columns = only_sir_columns)
} }
@ -338,6 +410,10 @@ lipoglycopeptides <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
macrolides <- function(only_sir_columns = FALSE, ...) { macrolides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("macrolides", only_sir_columns = only_sir_columns) ab_select_exec("macrolides", only_sir_columns = only_sir_columns)
} }
@ -345,6 +421,10 @@ macrolides <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
oxazolidinones <- function(only_sir_columns = FALSE, ...) { oxazolidinones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("oxazolidinones", only_sir_columns = only_sir_columns) ab_select_exec("oxazolidinones", only_sir_columns = only_sir_columns)
} }
@ -352,6 +432,10 @@ oxazolidinones <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
penicillins <- function(only_sir_columns = FALSE, ...) { penicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("penicillins", only_sir_columns = only_sir_columns) ab_select_exec("penicillins", only_sir_columns = only_sir_columns)
} }
@ -360,6 +444,10 @@ penicillins <- function(only_sir_columns = FALSE, ...) {
polymyxins <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) { polymyxins <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1) meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("polymyxins", only_sir_columns = only_sir_columns, only_treatable = only_treatable) ab_select_exec("polymyxins", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
} }
@ -367,6 +455,10 @@ polymyxins <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
#' @export #' @export
streptogramins <- function(only_sir_columns = FALSE, ...) { streptogramins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("streptogramins", only_sir_columns = only_sir_columns) ab_select_exec("streptogramins", only_sir_columns = only_sir_columns)
} }
@ -374,6 +466,10 @@ streptogramins <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
quinolones <- function(only_sir_columns = FALSE, ...) { quinolones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("quinolones", only_sir_columns = only_sir_columns) ab_select_exec("quinolones", only_sir_columns = only_sir_columns)
} }
@ -381,6 +477,10 @@ quinolones <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
tetracyclines <- function(only_sir_columns = FALSE, ...) { tetracyclines <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("tetracyclines", only_sir_columns = only_sir_columns) ab_select_exec("tetracyclines", only_sir_columns = only_sir_columns)
} }
@ -388,6 +488,10 @@ tetracyclines <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
trimethoprims <- function(only_sir_columns = FALSE, ...) { trimethoprims <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("trimethoprims", only_sir_columns = only_sir_columns) ab_select_exec("trimethoprims", only_sir_columns = only_sir_columns)
} }
@ -395,6 +499,10 @@ trimethoprims <- function(only_sir_columns = FALSE, ...) {
#' @export #' @export
ureidopenicillins <- function(only_sir_columns = FALSE, ...) { ureidopenicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
ab_select_exec("ureidopenicillins", only_sir_columns = only_sir_columns) ab_select_exec("ureidopenicillins", only_sir_columns = only_sir_columns)
} }

View File

@ -191,11 +191,12 @@
#' # with a custom language, though this will be determined automatically #' # with a custom language, though this will be determined automatically
#' # (i.e., this table will be in Spanish on Spanish systems) #' # (i.e., this table will be in Spanish on Spanish systems)
#' antibiogram(ex1, #' antibiogram(ex1,
#' antibiotics = aminoglycosides(), #' antibiotics = aminoglycosides(),
#' ab_transform = "name", #' ab_transform = "name",
#' syndromic_group = ifelse(ex1$ward == "ICU", #' syndromic_group = ifelse(ex1$ward == "ICU",
#' "UCI", "No UCI"), #' "UCI", "No UCI"
#' language = "es" #' ),
#' language = "es"
#' ) #' )
#' #'
#' #'
@ -203,21 +204,22 @@
#' #'
#' # the data set could contain a filter for e.g. respiratory specimens/ICU #' # the data set could contain a filter for e.g. respiratory specimens/ICU
#' antibiogram(example_isolates, #' antibiogram(example_isolates,
#' antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"), #' antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain", #' mo_transform = "gramstain",
#' minimum = 10, # this should be >=30, but now just as example #' minimum = 10, # this should be >=30, but now just as example
#' syndromic_group = ifelse(example_isolates$age >= 65 & #' syndromic_group = ifelse(example_isolates$age >= 65 &
#' example_isolates$gender == "M", #' example_isolates$gender == "M",
#' "WISCA Group 1", "WISCA Group 2" #' "WISCA Group 1", "WISCA Group 2"
#' ) #' )
#' ) #' )
#' #'
#' #'
#' # Print the output for R Markdown / Quarto ----------------------------- #' # Print the output for R Markdown / Quarto -----------------------------
#' #'
#' ureido <- antibiogram(example_isolates, #' ureido <- antibiogram(example_isolates,
#' antibiotics = ureidopenicillins(), #' antibiotics = ureidopenicillins(),
#' ab_transform = "name") #' ab_transform = "name"
#' )
#' #'
#' # in an Rmd file, you would just need to return `ureido` in a chunk, #' # in an Rmd file, you would just need to return `ureido` in a chunk,
#' # but to be explicit here: #' # but to be explicit here:
@ -247,7 +249,6 @@
#' #'
#' plot(ab1) #' plot(ab1)
#' plot(ab2) #' plot(ab2)
#'
#' } #' }
antibiogram <- function(x, antibiogram <- function(x,
antibiotics = where(is.sir), antibiotics = where(is.sir),

View File

@ -181,6 +181,7 @@ eucast_rules <- function(x,
meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "sir"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE) meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "sir"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE) meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
if ("only_rsi_columns" %in% names(list(...))) only_sir_columns <- list(...)$only_rsi_columns
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()

View File

@ -226,6 +226,10 @@ first_isolate <- function(x = NULL,
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE) 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(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1) meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
if ("include_untested_rsi" %in% names(list(...))) {
deprecation_warning("include_untested_rsi", "include_untested_sir", is_function = FALSE)
include_untested_sir <- list(...)$include_untested_rsi
}
meet_criteria(include_untested_sir, allow_class = "logical", has_length = 1) meet_criteria(include_untested_sir, allow_class = "logical", has_length = 1)
# remove data.table, grouping from tibbles, etc. # remove data.table, grouping from tibbles, etc.

View File

@ -149,6 +149,10 @@ key_antimicrobials <- function(x = NULL,
meet_criteria(gram_positive, allow_class = "character", allow_NULL = TRUE) meet_criteria(gram_positive, allow_class = "character", allow_NULL = TRUE)
meet_criteria(antifungal, allow_class = "character", allow_NULL = TRUE) meet_criteria(antifungal, allow_class = "character", allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
# force regular data.frame, not a tibble or data.table # force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)

View File

@ -192,6 +192,10 @@ mdro <- function(x = NULL,
meet_criteria(pct_required_classes, allow_class = "numeric", has_length = 1) meet_criteria(pct_required_classes, allow_class = "numeric", has_length = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1) meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(verbose, allow_class = "logical", has_length = 1) meet_criteria(verbose, allow_class = "logical", has_length = 1)
if ("only_rsi_columns" %in% names(list(...))) {
deprecation_warning("only_rsi_columns", "only_sir_columns", is_function = FALSE)
only_sir_columns <- list(...)$only_rsi_columns
}
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if (!any(is_sir_eligible(x))) { if (!any(is_sir_eligible(x))) {

160
R/plot.R
View File

@ -88,8 +88,8 @@ plot.mic <- function(x,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
main = deparse(substitute(x)), main = deparse(substitute(x)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Minimum Inhibitory Concentration (mg/L)", xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -100,18 +100,14 @@ plot.mic <- function(x,
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1) meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1) meet_criteria(xlab, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_SIR) == 1) { if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3) colours_SIR <- rep(colours_SIR, 3)
} }
@ -180,8 +176,8 @@ barplot.mic <- function(height,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
main = deparse(substitute(height)), main = deparse(substitute(height)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Minimum Inhibitory Concentration (mg/L)", xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -192,18 +188,14 @@ barplot.mic <- function(height,
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE) meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " ")) main <- gsub(" +", " ", paste0(main, collapse = " "))
plot( plot(
@ -227,8 +219,8 @@ autoplot.mic <- function(object,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
title = deparse(substitute(object)), title = deparse(substitute(object)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Minimum Inhibitory Concentration (mg/L)", xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -240,18 +232,14 @@ autoplot.mic <- function(object,
meet_criteria(title, allow_class = "character", allow_NULL = TRUE) meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1) meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1) meet_criteria(xlab, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) { if ("main" %in% names(list(...))) {
title <- list(...)$main title <- list(...)$main
} }
@ -278,12 +266,15 @@ autoplot.mic <- function(object,
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline)) df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant" df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
df$cols <- factor(translate_into_language(df$cols, language = language), df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("(S) Susceptible", levels = translate_into_language(
paste("(I)", plot_name_of_I(cols_sub$guideline)), c(
"(R) Resistant"), "(S) Susceptible",
language = language paste("(I)", plot_name_of_I(cols_sub$guideline)),
), "(R) Resistant"
ordered = TRUE ),
language = language
),
ordered = TRUE
) )
p <- ggplot2::ggplot(df) p <- ggplot2::ggplot(df)
@ -328,8 +319,8 @@ fortify.mic <- function(object, ...) {
#' @rdname plot #' @rdname plot
plot.disk <- function(x, plot.disk <- function(x,
main = deparse(substitute(x)), main = deparse(substitute(x)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Disk diffusion diameter (mm)", xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
mo = NULL, mo = NULL,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
@ -343,18 +334,14 @@ plot.disk <- function(x,
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE) meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_SIR) == 1) { if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3) colours_SIR <- rep(colours_SIR, 3)
} }
@ -420,8 +407,8 @@ plot.disk <- function(x,
#' @noRd #' @noRd
barplot.disk <- function(height, barplot.disk <- function(height,
main = deparse(substitute(height)), main = deparse(substitute(height)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Disk diffusion diameter (mm)", xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
mo = NULL, mo = NULL,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
@ -435,18 +422,14 @@ barplot.disk <- function(height,
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE) meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " ")) main <- gsub(" +", " ", paste0(main, collapse = " "))
plot( plot(
@ -469,8 +452,8 @@ autoplot.disk <- function(object,
mo = NULL, mo = NULL,
ab = NULL, ab = NULL,
title = deparse(substitute(object)), title = deparse(substitute(object)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Disk diffusion diameter (mm)", xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
guideline = "EUCAST", guideline = "EUCAST",
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
@ -483,18 +466,14 @@ autoplot.disk <- function(object,
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE) meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE) meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) { if ("main" %in% names(list(...))) {
title <- list(...)$main title <- list(...)$main
} }
@ -522,9 +501,12 @@ autoplot.disk <- function(object,
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline)) df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant" df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
df$cols <- factor(translate_into_language(df$cols, language = language), df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("(S) Susceptible", levels = translate_into_language(
paste("(I)", plot_name_of_I(cols_sub$guideline)), c(
"(R) Resistant"), "(S) Susceptible",
paste("(I)", plot_name_of_I(cols_sub$guideline)),
"(R) Resistant"
),
language = language language = language
), ),
ordered = TRUE ordered = TRUE
@ -571,8 +553,8 @@ fortify.disk <- function(object, ...) {
#' @importFrom graphics plot text axis #' @importFrom graphics plot text axis
#' @rdname plot #' @rdname plot
plot.sir <- function(x, plot.sir <- function(x,
ylab = "Percentage", ylab = translate_AMR("Percentage", language = language),
xlab = "Antimicrobial Interpretation", xlab = translate_AMR("Antimicrobial Interpretation", language = language),
main = deparse(substitute(x)), main = deparse(substitute(x)),
language = get_AMR_locale(), language = get_AMR_locale(),
...) { ...) {
@ -580,14 +562,6 @@ plot.sir <- function(x,
meet_criteria(xlab, allow_class = "character", has_length = 1) meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
data <- as.data.frame(table(x), stringsAsFactors = FALSE) data <- as.data.frame(table(x), stringsAsFactors = FALSE)
colnames(data) <- c("x", "n") colnames(data) <- c("x", "n")
data$s <- round((data$n / sum(data$n)) * 100, 1) data$s <- round((data$n / sum(data$n)) * 100, 1)
@ -635,8 +609,8 @@ plot.sir <- function(x,
#' @noRd #' @noRd
barplot.sir <- function(height, barplot.sir <- function(height,
main = deparse(substitute(height)), main = deparse(substitute(height)),
xlab = "Antimicrobial Interpretation", xlab = translate_AMR("Antimicrobial Interpretation", language = language),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -644,18 +618,14 @@ barplot.sir <- function(height,
meet_criteria(xlab, allow_class = "character", has_length = 1) meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1) meet_criteria(ylab, allow_class = "character", has_length = 1)
if ("colours_RSI" %in% names(list(...))) {
deprecation_warning(extra_msg = "The 'colours_RSI' argument has been replaced with 'colours_SIR'.")
colours_SIR <- list(...)$colours_RSI
}
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language) language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1) meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_SIR) == 1) { if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3) colours_SIR <- rep(colours_SIR, 3)
} }
@ -678,8 +648,8 @@ barplot.sir <- function(height,
# will be exported using s3_register() in R/zzz.R # will be exported using s3_register() in R/zzz.R
autoplot.sir <- function(object, autoplot.sir <- function(object,
title = deparse(substitute(object)), title = deparse(substitute(object)),
xlab = "Antimicrobial Interpretation", xlab = translate_AMR("Antimicrobial Interpretation", language = language),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
...) { ...) {
@ -689,14 +659,6 @@ autoplot.sir <- function(object,
meet_criteria(xlab, allow_class = "character", has_length = 1) meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3)) meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
}
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) { if ("main" %in% names(list(...))) {
title <- list(...)$main title <- list(...)$main
} }

View File

@ -83,6 +83,10 @@ random_disk <- function(size = NULL, mo = NULL, ab = NULL, ...) {
#' @export #' @export
random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) { random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) {
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE) meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
if ("prob_RSI" %in% names(list(...))) {
deprecation_warning("prob_RSI", "prob_SIR", is_function = FALSE)
prob_SIR <- list(...)$prob_RSI
}
meet_criteria(prob_SIR, allow_class = c("numeric", "integer"), has_length = 3) meet_criteria(prob_SIR, allow_class = c("numeric", "integer"), has_length = 3)
if (is.null(size)) { if (is.null(size)) {
size <- NROW(get_current_data(arg_name = "size", call = -3)) size <- NROW(get_current_data(arg_name = "size", call = -3))
@ -91,7 +95,7 @@ random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) {
} }
random_exec <- function(type, size, mo = NULL, ab = NULL) { random_exec <- function(type, size, mo = NULL, ab = NULL) {
df <- clinical_breakpoints %pm>% df <- AMR::clinical_breakpoints %pm>%
pm_filter(guideline %like% "EUCAST") %pm>% pm_filter(guideline %like% "EUCAST") %pm>%
pm_arrange(pm_desc(guideline)) %pm>% pm_arrange(pm_desc(guideline)) %pm>%
subset(guideline == max(guideline) & subset(guideline == max(guideline) &

View File

@ -775,7 +775,7 @@ as_sir_method <- function(method_short,
} else { } else {
mo.bak <- mo mo.bak <- mo
} }
# be sure to take current taxonomy, as the clinical_breakpoints data set only contains current taxonomy # be sure to take current taxonomy, as the 'clinical_breakpoints' data set only contains current taxonomy
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, inf0 = FALSE))) mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, inf0 = FALSE)))
guideline_coerced <- get_guideline(guideline, reference_data) guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab)) { if (is.na(ab)) {

View File

@ -189,21 +189,33 @@ summary.rsi <- summary.sir
#' @export #' @export
unique.rsi <- unique.sir unique.rsi <- unique.sir
# WHEN REMOVING RSI, DON'T FORGET TO REMOVE THE "rsi_df" CLASS FROM R/sir_calc.R # WHEN REMOVING RSI, DON'T FORGET TO REMOVE :
# - THE "rsi_df" CLASS FROM R/sir_calc.R
# - CODE CONTAINING only_rsi_columns, colours_RSI, include_untested_rsi, prob_RSI
deprecation_warning <- function(old = NULL, new = NULL, extra_msg = NULL) { deprecation_warning <- function(old = NULL, new = NULL, extra_msg = NULL, is_function = TRUE) {
if (is.null(old)) { if (is.null(old)) {
warning_(extra_msg) warning_(extra_msg)
} else { } else {
env <- paste0("deprecated_", old) env <- paste0("deprecated_", old)
if (!env %in% names(AMR_env)) { if (!env %in% names(AMR_env)) {
AMR_env[[paste0("deprecated_", old)]] <- 1 AMR_env[[paste0("deprecated_", old)]] <- 1
if (isTRUE(is_function)) {
old <- paste0(old, "()")
new <- paste0(new, "()")
type <- "function"
} else {
type <- "argument"
}
warning_( warning_(
ifelse(is.null(new), ifelse(is.null(new),
paste0("The `", old, "()` function is no longer in use"), paste0("The `", old, "` ", type, " is no longer in use"),
paste0("The `", old, "()` function has been replaced with `", new, "()`") paste0("The `", old, "` ", type, " has been replaced with `", new, "`")
),
ifelse(type == "argument",
". While the old argument still works, it will be removed in a future version, so please update your code.",
", see `?AMR-deprecated`."
), ),
", see `?AMR-deprecated`.",
ifelse(!is.null(extra_msg), ifelse(!is.null(extra_msg),
paste0(" ", extra_msg), paste0(" ", extra_msg),
"" ""

View File

@ -1366,8 +1366,10 @@ microorganisms <- taxonomy
# https://lpsn.dsmz.de/species/stenotrophomonas-maltophilia # https://lpsn.dsmz.de/species/stenotrophomonas-maltophilia
# all MO's to keep as 'accepted', not as 'synonym': # all MO's to keep as 'accepted', not as 'synonym':
to_restore <- c("Stenotrophomonas maltophilia", to_restore <- c(
"Moraxella catarrhalis") "Stenotrophomonas maltophilia",
"Moraxella catarrhalis"
)
all(to_restore %in% microorganisms$fullname) all(to_restore %in% microorganisms$fullname)
for (nm in to_restore) { for (nm in to_restore) {
microorganisms$lpsn_renamed_to[which(microorganisms$fullname == nm)] <- NA microorganisms$lpsn_renamed_to[which(microorganisms$fullname == nm)] <- NA

View File

@ -214,11 +214,12 @@ ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
# with a custom language, though this will be determined automatically # with a custom language, though this will be determined automatically
# (i.e., this table will be in Spanish on Spanish systems) # (i.e., this table will be in Spanish on Spanish systems)
antibiogram(ex1, antibiogram(ex1,
antibiotics = aminoglycosides(), antibiotics = aminoglycosides(),
ab_transform = "name", ab_transform = "name",
syndromic_group = ifelse(ex1$ward == "ICU", syndromic_group = ifelse(ex1$ward == "ICU",
"UCI", "No UCI"), "UCI", "No UCI"
language = "es" ),
language = "es"
) )
@ -226,21 +227,22 @@ antibiogram(ex1,
# the data set could contain a filter for e.g. respiratory specimens/ICU # the data set could contain a filter for e.g. respiratory specimens/ICU
antibiogram(example_isolates, antibiogram(example_isolates,
antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"), antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain", mo_transform = "gramstain",
minimum = 10, # this should be >=30, but now just as example minimum = 10, # this should be >=30, but now just as example
syndromic_group = ifelse(example_isolates$age >= 65 & syndromic_group = ifelse(example_isolates$age >= 65 &
example_isolates$gender == "M", example_isolates$gender == "M",
"WISCA Group 1", "WISCA Group 2" "WISCA Group 1", "WISCA Group 2"
) )
) )
# Print the output for R Markdown / Quarto ----------------------------- # Print the output for R Markdown / Quarto -----------------------------
ureido <- antibiogram(example_isolates, ureido <- antibiogram(example_isolates,
antibiotics = ureidopenicillins(), antibiotics = ureidopenicillins(),
ab_transform = "name") ab_transform = "name"
)
# in an Rmd file, you would just need to return `ureido` in a chunk, # in an Rmd file, you would just need to return `ureido` in a chunk,
# but to be explicit here: # but to be explicit here:
@ -270,6 +272,5 @@ if (requireNamespace("ggplot2")) {
plot(ab1) plot(ab1)
plot(ab2) plot(ab2)
} }
} }

View File

@ -19,8 +19,8 @@
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
main = deparse(substitute(x)), main = deparse(substitute(x)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Minimum Inhibitory Concentration (mg/L)", xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -33,8 +33,8 @@
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
title = deparse(substitute(object)), title = deparse(substitute(object)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Minimum Inhibitory Concentration (mg/L)", xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
expand = TRUE, expand = TRUE,
@ -46,8 +46,8 @@
\method{plot}{disk}( \method{plot}{disk}(
x, x,
main = deparse(substitute(x)), main = deparse(substitute(x)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Disk diffusion diameter (mm)", xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
mo = NULL, mo = NULL,
ab = NULL, ab = NULL,
guideline = "EUCAST", guideline = "EUCAST",
@ -62,8 +62,8 @@
mo = NULL, mo = NULL,
ab = NULL, ab = NULL,
title = deparse(substitute(object)), title = deparse(substitute(object)),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
xlab = "Disk diffusion diameter (mm)", xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
guideline = "EUCAST", guideline = "EUCAST",
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
@ -75,8 +75,8 @@
\method{plot}{sir}( \method{plot}{sir}(
x, x,
ylab = "Percentage", ylab = translate_AMR("Percentage", language = language),
xlab = "Antimicrobial Interpretation", xlab = translate_AMR("Antimicrobial Interpretation", language = language),
main = deparse(substitute(x)), main = deparse(substitute(x)),
language = get_AMR_locale(), language = get_AMR_locale(),
... ...
@ -85,8 +85,8 @@
\method{autoplot}{sir}( \method{autoplot}{sir}(
object, object,
title = deparse(substitute(object)), title = deparse(substitute(object)),
xlab = "Antimicrobial Interpretation", xlab = translate_AMR("Antimicrobial Interpretation", language = language),
ylab = "Frequency", ylab = translate_AMR("Frequency", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"), colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(), language = get_AMR_locale(),
... ...

View File

@ -255,42 +255,48 @@ Below are some suggestions for how to generate the different antibiograms:
# traditional: # traditional:
antibiogram(our_data_1st) antibiogram(our_data_1st)
antibiogram(our_data_1st, antibiogram(our_data_1st,
ab_transform = "name") ab_transform = "name"
)
antibiogram(our_data_1st, antibiogram(our_data_1st,
ab_transform = "name", ab_transform = "name",
language = "es") # support for 20 languages language = "es"
) # support for 20 languages
``` ```
```{r} ```{r}
# combined: # combined:
antibiogram(our_data_1st, antibiogram(our_data_1st,
antibiotics = c("AMC", "AMC+CIP", "AMC+GEN")) antibiotics = c("AMC", "AMC+CIP", "AMC+GEN")
)
``` ```
```{r} ```{r}
# for a syndromic antibiogram, we must fake some clinical conditions: # for a syndromic antibiogram, we must fake some clinical conditions:
our_data_1st$condition <- sample(c("Cardial", "Respiratory", "Rheumatic"), our_data_1st$condition <- sample(c("Cardial", "Respiratory", "Rheumatic"),
size = nrow(our_data_1st), size = nrow(our_data_1st),
replace = TRUE) replace = TRUE
)
# syndromic: # syndromic:
antibiogram(our_data_1st, antibiogram(our_data_1st,
syndromic_group = "condition") syndromic_group = "condition"
)
antibiogram(our_data_1st, antibiogram(our_data_1st,
# you can use AB selectors here as well: # you can use AB selectors here as well:
antibiotics = c(penicillins(), aminoglycosides()), antibiotics = c(penicillins(), aminoglycosides()),
syndromic_group = "condition", syndromic_group = "condition",
mo_transform = "gramstain") mo_transform = "gramstain"
)
``` ```
```{r} ```{r}
# WISCA: # WISCA:
# (we lack some details, but it could contain a filter on e.g. >65 year-old males) # (we lack some details, but it could contain a filter on e.g. >65 year-old males)
wisca <- antibiogram(our_data_1st, wisca <- antibiogram(our_data_1st,
antibiotics = c("AMC", "AMC+CIP", "AMC+GEN"), antibiotics = c("AMC", "AMC+CIP", "AMC+GEN"),
syndromic_group = "condition", syndromic_group = "condition",
mo_transform = "gramstain") mo_transform = "gramstain"
)
wisca wisca
``` ```