Merge branch 'master' into test/data-functions-edge-cases

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)
 
 * Added singleton-dimension edge-case tests for exported `_data()` functions.
+* 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

@@ -589,4 +589,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])
+  )
+}