(v1.5.0.9001) more informative argument errors

R/aa_helper_functions.R

@@ -479,12 +479,39 @@ meet_criteria <- function(object,
     stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
     return(invisible())
   }
+  
+  translate_class <- function(allow_class, plural = isTRUE(has_length > 1)) {
+    allow_class.bak <- allow_class
+    allow_class[allow_class %in% c("numeric", "double")] <- "number"
+    allow_class[allow_class == "integer"] <- "whole number"
+    if (any(c("numeric", "double") %in% allow_class.bak, na.rm = TRUE) & "integer" %in% allow_class.bak) {
+      allow_class[allow_class %in% c("number", "whole number")] <- "(whole) number"
+    }
+    allow_class[allow_class == "character"] <- "text string"
+    allow_class[allow_class %in% c("Date", "POSIXt")] <- "date"
+    allow_class[allow_class != allow_class.bak] <- paste0(ifelse(plural, "", "a "),
+                                                          allow_class[allow_class != allow_class.bak],
+                                                          ifelse(plural, "s", ""))
+    # exceptions
+    allow_class[allow_class == "logical"] <- ifelse(plural, "a vector of `TRUE`/`FALSE`", "`TRUE` or `FALSE`")
+    if ("data.frame" %in% allow_class) {
+      allow_class <- "a data set"
+    }
+    if ("list" %in% allow_class) {
+      allow_class <- "a list"
+    }
+    if ("matrix" %in% allow_class) {
+      allow_class <- "a matrix"
+    }
+    allow_class[allow_class == allow_class.bak] <- paste0("a class <", allow_class[allow_class == allow_class.bak], ">")
+    # output
+    vector_or(allow_class, quotes = FALSE)
+  }
 
   if (!is.null(allow_class)) {
     stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
-               "` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
-               "be of class ", vector_or(allow_class, quotes = TRUE),
-               ", not \"", paste(class(object), collapse = "/"), "\"",
+               "` must be ", translate_class(allow_class),
+               ", not ", translate_class(class(object)),
                call = call_depth)
     # check data.frames for data
     if (inherits(object, "data.frame")) {
@@ -515,9 +542,8 @@ meet_criteria <- function(object,
     }
     stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name,
                "` must be ",
-               ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, "one of: ", ""),
-               vector_or(is_in, quotes = TRUE),
-               ", not ", paste0("\"", object, "\"", collapse = "/"), "",
+               ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, "either ", ""),
+               vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
                call = call_depth)
   }
   if (!is.null(contains_column_class)) {

R/ab.R

@@ -82,6 +82,14 @@
 #' # they use as.ab() internally:
 #' ab_name("J01FA01")    # "Erythromycin"
 #' ab_name("eryt")       # "Erythromycin"
+#' 
+#' if (require("dplyr")) {
+#' 
+#'   # you can quickly rename <rsi> columns using dplyr >= 1.0.0:
+#'   example_isolates %>%
+#'     rename_with(as.ab, where(is.rsi))
+#'    
+#' }
 as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
   meet_criteria(x, allow_class = c("character", "numeric", "integer", "factor"), allow_NA = TRUE)
   meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)

R/data.R

@@ -285,7 +285,7 @@ catalogue_of_life <- list(
 #' - `name`\cr Official name of the antimicrobial agent as used by WHONET/EARS-Net or the WHO
 #' - `type`\cr Type of the dosage, either `r vector_or(dosage$type)`
 #' - `dose`\cr Dose, such as "2 g" or "25 mg/kg"
-#' - `dose_times`\cr Dose, such as "2 g" or "25 mg/kg"
+#' - `dose_times`\cr Number of times a dose must be administered
 #' - `administration`\cr Route of administration, either `r vector_or(dosage$administration)`
 #' - `notes`\cr Additional dosage notes
 #' - `original_txt`\cr Original text in the PDF file of EUCAST

R/eucast_rules.R

@@ -58,7 +58,7 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
 #' Apply EUCAST rules
 #' 
 #' @description
-#' Apply rules for clinical breakpoints and intrinsic resistance as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://eucast.org>), see *Source*. Use [eucast_dosage()] to get advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
+#' Apply rules for clinical breakpoints and intrinsic resistance as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
 #' 
 #' To improve the interpretation of the antibiogram before EUCAST rules are applied, some non-EUCAST rules can applied at default, see Details.
 #' @inheritSection lifecycle Stable lifecycle
@@ -166,8 +166,8 @@ eucast_rules <- function(x,
   meet_criteria(info, allow_class = "logical", has_length = 1)
   meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4), is_in = c("breakpoints", "expert", "other", "all"))
   meet_criteria(verbose, allow_class = "logical", has_length = 1)
-  meet_criteria(version_breakpoints, allow_class = "numeric", has_length = 1)
-  meet_criteria(version_expertrules, allow_class = "numeric", has_length = 1)
+  meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
+  meet_criteria(version_expertrules, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_EXPERT_RULES)))
   meet_criteria(ampc_cephalosporin_resistance, allow_class = c("rsi", "character"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE, is_in = c("R", "S", "I"))
   
   x_deparsed <- deparse(substitute(x))
@@ -177,12 +177,6 @@ eucast_rules <- function(x,
   
   check_dataset_integrity()
   
-  version_breakpoints <- as.double(gsub("[^0-9.]+", "", version_breakpoints))
-  version_expertrules <- as.double(gsub("[^0-9.]+", "", version_expertrules))
-  stop_ifnot(version_breakpoints %in% as.double(names(EUCAST_VERSION_BREAKPOINTS)),
-             "EUCAST version ", version_breakpoints, " for clinical breakpoints not found")
-  stop_ifnot(version_expertrules %in% as.double(names(EUCAST_VERSION_EXPERT_RULES)),
-             "EUCAST version ", version_expertrules, " for expert rules/intrinsic resistance not found")
   breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
   expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
   
@@ -1180,6 +1174,10 @@ edit_rsi <- function(x,
 #' @rdname eucast_rules
 #' @export
 eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0) {
+  meet_criteria(ab, allow_class = c("character", "numeric", "integer", "factor"))
+  meet_criteria(administration, allow_class = "character", is_in = dosage$administration[!is.na(dosage$administration)])
+  meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
+  
   # show used version_breakpoints number once per session (pkg_env will reload every session)
   if (message_not_thrown_before(paste0("eucast_dosage_v", gsub("[^0-9]", "", version_breakpoints)), entire_session = TRUE)) {
     message_("Dosages for antimicrobial drugs, as meant for ",
@@ -1187,15 +1185,11 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 11.0)
              font_red("This note will be shown once per session."))
     remember_thrown_message(paste0("eucast_dosage_v", gsub("[^0-9]", "", version_breakpoints)), entire_session = TRUE)
   }
+  
   ab <- as.ab(ab)
-  out <- character(length(ab))
-  for (i in seq_len(length(ab))) {
-    df <- data.frame(ab = ab[i], stringsAsFactors = FALSE, administration = administration) %pm>%
-      pm_inner_join(AMR::dosage, by = c("ab", "administration")) %pm>%
-      pm_mutate(txt = paste0(gsub("_", " ", type), ": ", dose_times, "x ", dose, " ", administration), perl = TRUE)
-    out[i] <- paste(df$txt, collapse = ", ")
-  }
-  names(out) <- ab_name(ab, language = NULL)
-  out[out == ""] <- NA_character_
-  out
+  df <- AMR::dosage[which(AMR::dosage$ab %in% ab & AMR::dosage$administration %in% administration), , drop = FALSE]
+  df <- df[match(ab, df$ab), colnames(df)[colnames(df) != "administration"], drop = FALSE]
+  rownames(df) <- NULL
+  df$ab <- ab
+  df
 }

R/globals.R

@@ -33,6 +33,8 @@ globalVariables(c(".rowid",
                   "atc_group2",
                   "code",
                   "data",
+                  "dose",
+                  "dose_times",
                   "fullname",
                   "fullname_lower",
                   "g_species",
@@ -73,6 +75,7 @@ globalVariables(c(".rowid",
                   "species_id",
                   "total",
                   "txt",
+                  "type",
                   "value",
                   "varname",
                   "xvar",