Merge branch 'master' into fix/validate-chain-list-colnames-check

Author: jgabry

DESCRIPTION

@@ -13,7 +13,8 @@ Authors@R: c(person("Jonah", "Gabry", role = c("aut", "cre"), email = "jgabry@gm
              person("Teemu", "Sailynoja", role = "ctb"),
              person("Aki", "Vehtari", role = "ctb"), 
              person("Behram", "Ulukır", role = "ctb"), 
-             person("Visruth", "Srimath Kandali", role = "ctb"))
+             person("Visruth", "Srimath Kandali", role = "ctb"),
+             person("Mattan S.", "Ben-Shachar", role = "ctb"))
 Maintainer: Jonah Gabry <jgabry@gmail.com>
 Description: Plotting functions for posterior analysis, MCMC diagnostics,
     prior and posterior predictive checks, and other visualizations

NEWS.md

@@ -1,6 +1,7 @@
 # bayesplot (development version)
 
 * Fixed `validate_chain_list()` colnames check to compare all chains, not just the first two.
+* New `show_marginal` argument to `ppd_*()` functions to show the PPD - the marginal predictive distribution by @mattansb (#425)
 * `ppc_ecdf_overlay()`, `ppc_ecdf_overlay_grouped()`, and `ppd_ecdf_overlay()` now always use `geom_step()`. The `discrete` argument is deprecated.
 * Fixed missing `drop = FALSE` in `nuts_params.CmdStanMCMC()`.
 * Replace `apply()` with `storage.mode()` for integer-to-numeric matrix conversion in `validate_predictions()`.

R/helpers-gg.R

@@ -96,7 +96,7 @@ scale_color_ppc <-
            labels = NULL,
            ...) {
     scale_color_manual(
-      name = name %||% "",
+      name = name,
       values = values %||% get_color(c("dh", "lh")),
       labels = labels %||% c(y_label(), yrep_label()),
       ...
@@ -109,7 +109,7 @@ scale_fill_ppc <-
            labels = NULL,
            ...) {
     scale_fill_manual(
-      name = name %||% "",
+      name = name,
       values = values %||% get_color(c("d", "l")),
       labels = labels %||% c(y_label(), yrep_label()),
       ...
@@ -118,22 +118,77 @@ scale_fill_ppc <-
 
 scale_color_ppd <-
   function(name = NULL,
-           values = get_color("mh"),
-           labels = ypred_label(),
+           values = NULL,
+           labels = NULL,
+           highlight = TRUE,
+           show_marginal = FALSE,
            ...) {
-    scale_color_ppc(name = name,
-                    values = values,
-                    labels = labels,
-                    ...)
+    if (isTRUE(show_marginal)) {
+      if (isTRUE(highlight)) {
+        cl <- c("dh", "lh")
+      } else {
+        cl <- c("d", "l")
+      }
+      default_values <- setNames(get_color(cl), nm = c("PPD", "ypred"))
+    } else {
+      if (isTRUE(highlight)) {
+        default_values <- get_color("mh")
+      } else {
+        default_values <- get_color("m")
+      }
+    }
+
+    scale_color_ppc(
+      name = name,
+      values = values %||% default_values,
+      labels = labels %||% ypred_label(),
+      ...
+    )
   }
 
 scale_fill_ppd <-
   function(name = NULL,
-           values = get_color("m"),
-           labels = ypred_label(),
+           values = NULL,
+           labels = NULL,
+           show_marginal = FALSE,
            ...) {
-    scale_fill_ppc(name = name,
-                   values = values,
-                   labels = labels,
-                   ...)
+    if (isTRUE(show_marginal)) {
+      default_values <- c(PPD = "white", ypred = get_color("l"))
+    } else {
+      default_values <- get_color("m")
+    }
+
+    scale_fill_ppc(
+      name = name,
+      values = values %||% default_values,
+      labels = labels %||% ypred_label(),
+      ...
+    )
+  }
+
+
+scale_linetype_ppd <-
+  function(name = NULL,
+           values = NULL,
+           labels = NULL,
+           ...) {
+    scale_linetype_manual(
+      name = name,
+      values = values %||% c(PPD = "5111", ypred = "solid"),
+      labels = labels %||% ypred_label(),
+      ...
+    )
+  }
+
+scale_shape_ppd <-
+  function(name = NULL,
+           values = NULL,
+           labels = NULL,
+           ...) {
+    scale_shape_manual(
+      name = name,
+      values = values %||% c(ypred = 21, PPD = 23),
+      labels = labels %||% ypred_label(),
+      ...
+    )
   }

R/helpers-ppc.R

@@ -58,15 +58,20 @@ validate_y <- function(y) {
 #' Validate predictions (`yrep` or `ypred`)
 #'
 #' Checks that `predictions` is a numeric matrix, doesn't have any NAs, and has
-#' the correct number of columns.
+#' the correct number of columns. If `predictions` is a `posterior::draws`
+#' object it is first coerced to a matrix.
 #'
-#' @param predictions The user's `yrep` or `ypred` object (SxN matrix).
+#' @param predictions The user's `yrep` or `ypred` object (SxN matrix or a
+#'   `posterior::draws` object).
 #' @param `n_obs` The number of observations (columns) that `predictions` should
 #'   have, if applicable.
 #' @return Either throws an error or returns a numeric matrix.
 #' @noRd
 validate_predictions <- function(predictions, n_obs = NULL) {
-  # sanity checks
+  if (posterior::is_draws(predictions)) {
+    predictions <- posterior::as_draws_matrix(predictions)
+    predictions <- unclass(predictions)
+  }
   stopifnot(is.matrix(predictions), is.numeric(predictions))
   if (!is.null(n_obs)) {
     stopifnot(length(n_obs) == 1, n_obs == as.integer(n_obs))
@@ -589,4 +594,9 @@ u_scale <- function(x) {
 create_rep_ids <- function(ids) paste('italic(y)[rep] (', ids, ")")
 y_label <- function() expression(italic(y))
 yrep_label <- function() expression(italic(y)[rep])
-ypred_label <- function() expression(italic(y)[pred])
+ypred_label <- function() {
+  c(
+    PPD = "PPD",
+    ypred = expression(italic(y)[pred])
+  )
+}