Add marginal dist. to PPD plots

NEWS.md

@@ -1,5 +1,7 @@
 # bayesplot (development version)
 
+
+* New `show_marginal` argument to `ppd_*()` functions to show the PPD - the marginal predictive distribution by @mattansb (#425)
 * Standardize input validation errors in `ppc_km_overlay()` and interpolation helpers to use `rlang::abort()` for consistent error handling.
 * Fix assignment-in-call bug in `mcmc_rank_ecdf()` (#).
 * Replaced deprecated `dplyr` and `tidyselect` functions (`top_n`, `one_of`, `group_indices`) with their modern equivalents to ensure future compatibility. (#431)
@@ -24,7 +26,7 @@
 
 # bayesplot 1.14.0
 
-* PPC "avg" functions (`ppc_scatter_avg()`, `ppc_error_scatter_avg()`, etc.) gain a `stat` argument 
+* PPC "avg" functions (`ppc_scatter_avg()`, `ppc_error_scatter_avg()`, etc.) gain a `stat` argument
   to set the averaging function. (Suggestion of #348, @kruschke).
 * `ppc_error_scatter_avg_vs_x(x = some_expression)` labels the x axis with `some_expression`.
 * New quantile dot plot functions `ppc_dots()` and `ppd_dots()` by @behramulukir (#357)
@@ -46,7 +48,7 @@
 
 * Expand checking workflows to more platforms by @andrjohns (#324)
 * Skip tests depending on Suggested dependency rstantools if not installed by @MichaelChirico (#325)
-* Skip tests depending on Suggested dependency gridExtra if not installed by @MichaelChirico (#326) 
+* Skip tests depending on Suggested dependency gridExtra if not installed by @MichaelChirico (#326)
 * Fix missing legends for unobserved levels in rhat and neff plots (#328)
 * Document problems with `ppc_stat` with `stat="mean"` (#329)
 * Ensure rank overlay plot starts at 0 even if not all bins present, thanks @sims1253 (#332)

R/helpers-gg.R

@@ -118,22 +118,50 @@ 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 <- setNames(get_color(c("d", "l")), nm = c("PPD", "ypred"))
+    } else {
+      default_values <- get_color("m")
+    }
+
+    scale_fill_ppc(
+      name = name,
+      values = values %||% default_values,
+      labels = labels %||% ypred_label(),
+      ...
+    )
   }

R/helpers-ppc.R

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