(v1.7.1.9053) fortify() methods

R/aa_helper_functions.R

@@ -53,15 +53,68 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
   merged
 }
 
-quick_case_when <- function(...) {
-  vectors <- list(...)
-  split <- lapply(vectors, function(x) unlist(strsplit(paste(deparse(x), collapse = ""), "~", fixed = TRUE)))
-  for (i in seq_len(length(vectors))) {
-    if (eval(parse(text = split[[i]][1]), envir = parent.frame())) {
-      return(eval(parse(text = split[[i]][2]), envir = parent.frame()))
+# copied and slightly rewritten from poorman under same license (2021-10-15)
+quick_case_when <- function (...) {
+  fs <- list(...)
+  lapply(fs, function(x) if (class(x) != "formula") 
+    stop("`case_when()` requires formula inputs."))
+  n <- length(fs)
+  if (n == 0L) 
+    stop("No cases provided.")
+  
+  validate_case_when_length <- function (query, value, fs) {
+    lhs_lengths <- lengths(query)
+    rhs_lengths <- lengths(value)
+    all_lengths <- unique(c(lhs_lengths, rhs_lengths))
+    if (length(all_lengths) <= 1L) 
+      return(all_lengths[[1L]])
+    non_atomic_lengths <- all_lengths[all_lengths != 1L]
+    len <- non_atomic_lengths[[1L]]
+    if (length(non_atomic_lengths) == 1L) 
+      return(len)
+    inconsistent_lengths <- non_atomic_lengths[-1L]
+    lhs_problems <- lhs_lengths %in% inconsistent_lengths
+    rhs_problems <- rhs_lengths %in% inconsistent_lengths
+    problems <- lhs_problems | rhs_problems
+    if (any(problems)) {
+      stop("The following formulas must be length ", len, " or 1, not ", 
+           paste(inconsistent_lengths, collapse = ", "), ".\n    ", 
+           paste(fs[problems], collapse = "\n    "),
+           call. = FALSE)
     }
   }
-  return(NA)
+  
+  replace_with <- function (x, i, val, arg_name) {
+    if (is.null(val)) 
+      return(x)
+    i[is.na(i)] <- FALSE
+    if (length(val) == 1L) {
+      x[i] <- val
+    }
+    else {
+      x[i] <- val[i]
+    }
+    x
+  }
+  
+  query <- vector("list", n)
+  value <- vector("list", n)
+  default_env <- parent.frame()
+  for (i in seq_len(n)) {
+    query[[i]] <- eval(fs[[i]][[2]], envir = default_env)
+    value[[i]] <- eval(fs[[i]][[3]], envir = default_env)
+    if (!is.logical(query[[i]])) 
+      stop(fs[[i]][[2]], " does not return a `logical` vector.")
+  }
+  m <- validate_case_when_length(query, value, fs)
+  out <- value[[1]][rep(NA_integer_, m)]
+  replaced <- rep(FALSE, m)
+  for (i in seq_len(n)) {
+    out <- replace_with(out, query[[i]] & !replaced, value[[i]], 
+                        NULL)
+    replaced <- replaced | (query[[i]] & !is.na(query[[i]]))
+  }
+  out
 }
 
 # No export, no Rd

R/plot.R

@@ -28,7 +28,7 @@
 #' Functions to plot classes `rsi`, `mic` and `disk`, with support for base \R and `ggplot2`.
 #' @inheritSection lifecycle Maturing Lifecycle
 #' @inheritSection AMR Read more on Our Website!
-#' @param x,object values created with [as.mic()], [as.disk()] or [as.rsi()]
+#' @param x,object values created with [as.mic()], [as.disk()] or [as.rsi()] (or their `random_*` variants, such as [random_mic()])
 #' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()]
 #' @param ab any (vector of) text that can be coerced to a valid antimicrobial code with [as.ab()]
 #' @param guideline interpretation guideline to use, defaults to the latest included EUCAST guideline, see *Details*
@@ -46,7 +46,9 @@
 #' @name plot
 #' @rdname plot
 #' @return The `autoplot()` functions return a [`ggplot`][ggplot2::ggplot()] model that is extendible with any `ggplot2` function.
-#' @param ... arguments passed on to [as.rsi()]
+#' 
+#' The `fortify()` functions return a [data.frame] as an extension for usage in the [ggplot2::ggplot()] function.
+#' @param ... arguments passed on to methods
 #' @examples 
 #' some_mic_values <- random_mic(size = 100)
 #' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
@@ -283,6 +285,13 @@ autoplot.mic <- function(object,
     ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
 }
 
+#' @method fortify mic
+#' @rdname plot
+# will be exported using s3_register() in R/zzz.R
+fortify.mic <- function(object, ...) {
+  stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
+                  c("x", "y"))
+}
 
 #' @method plot disk
 #' @export
@@ -500,6 +509,14 @@ autoplot.disk <- function(object,
     ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
 }
 
+#' @method fortify disk
+#' @rdname plot
+# will be exported using s3_register() in R/zzz.R
+fortify.disk <- function(object, ...) {
+  stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
+                  c("x", "y"))
+}
+
 #' @method plot rsi
 #' @export
 #' @importFrom graphics plot text axis
@@ -646,6 +663,14 @@ autoplot.rsi <- function(object,
     ggplot2::theme(legend.position = "none")
 }
 
+#' @method fortify rsi
+#' @rdname plot
+# will be exported using s3_register() in R/zzz.R
+fortify.rsi <- function(object, ...) {
+  stats::setNames(as.data.frame(table(object)),
+                  c("x", "y"))
+}
+
 plot_prepare_table <- function(x, expand) {
   x <- x[!is.na(x)]
   stop_if(length(x) == 0, "no observations to plot", call = FALSE)

R/zzz.R

@@ -66,6 +66,10 @@ if (utf8_supported && !is_latex) {
   s3_register("ggplot2::autoplot", "mic")
   s3_register("ggplot2::autoplot", "disk")
   s3_register("ggplot2::autoplot", "resistance_predict")
+  # Support for fortify from the ggplot2 package
+  s3_register("ggplot2::fortify", "rsi")
+  s3_register("ggplot2::fortify", "mic")
+  s3_register("ggplot2::fortify", "disk")
   # Support vctrs package for use in e.g. dplyr verbs
   s3_register("vctrs::vec_ptype2", "ab.character")
   s3_register("vctrs::vec_ptype2", "character.ab")