Merge branch 'master' into fix/allow-nas-prepare-mcmc-array-250

Author: utkarshpawade

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,12 @@
 # bayesplot (development version)
 
 * `prepare_mcmc_array()` now warns instead of erroring on `NA`s in the input.
+* Fixed `validate_chain_list()` colnames check to compare all chains, not just the first two.
+* Added test verifying `legend_move("none")` behaves equivalently to `legend_none()`.
+* Added singleton-dimension edge-case tests for exported `_data()` functions.
+* Validate empty list and zero-row matrix inputs in `nuts_params.list()`.
+* Validate user-provided `pit` values in `ppc_loo_pit_data()` and `ppc_loo_pit_qq()`, rejecting non-numeric inputs, missing values, and values outside `[0, 1]`.
+* 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/bayesplot-extractors.R

@@ -145,10 +145,18 @@ nuts_params.stanreg <-
 #' @export
 #' @method nuts_params list
 nuts_params.list <- function(object, pars = NULL, ...) {
+  if (length(object) == 0) {
+    abort("'object' must be a non-empty list.")
+  }
+
   if (!all(sapply(object, is.matrix))) {
     abort("All list elements should be matrices.")
   }
 
+  if (any(vapply(object, nrow, integer(1)) == 0)) {
+    abort("All matrices in the list must have at least one row.")
+  }
+
   dd <- lapply(object, dim)
   if (length(unique(dd)) != 1) {
     abort("All matrices in the list must have the same dimensions.")

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-mcmc.R

@@ -279,12 +279,8 @@ validate_chain_list <- function(x) {
       abort("Each chain should have the same number of iterations.")
     }
 
-    cnames <- sapply(x, colnames)
-    if (is.array(cnames)) {
-      same_params <- identical(cnames[, 1], cnames[, 2])
-    } else {
-      same_params <- length(unique(cnames)) == 1
-    }
+    cnames <- lapply(x, colnames)
+    same_params <- all(vapply(cnames[-1], identical, logical(1), cnames[[1]]))
     if (!same_params) {
       abort(paste(
         "The parameters for each chain should be in the same order",

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

R/ppc-loo.R

@@ -302,7 +302,10 @@ ppc_loo_pit_data <-
            boundary_correction = TRUE,
            grid_len = 512) {
     if (!is.null(pit)) {
-      stopifnot(is.numeric(pit), is_vector_or_1Darray(pit))
+      pit <- validate_pit(pit)
+      if (boundary_correction && length(pit) < 2L) {
+        abort("At least 2 PIT values are required when 'boundary_correction' is TRUE.")
+      }
       inform("'pit' specified so ignoring 'y','yrep','lw' if specified.")
     } else {
       suggested_package("rstantools")
@@ -348,7 +351,7 @@ ppc_loo_pit_qq <- function(y,
 
   compare <- match.arg(compare)
   if (!is.null(pit)) {
-    stopifnot(is.numeric(pit), is_vector_or_1Darray(pit))
+    pit <- validate_pit(pit)
     inform("'pit' specified so ignoring 'y','yrep','lw' if specified.")
   } else {
     suggested_package("rstantools")
@@ -795,14 +798,6 @@ ppc_loo_ribbon <-
   # Generate boundary corrected values via a linear convolution using a
   # 1-D Gaussian window filter. This method uses the "reflection method"
   # to estimate these pvalues and helps speed up the code
-  if (any(is.infinite(x))) {
-    warn(paste(
-      "Ignored", sum(is.infinite(x)),
-      "Non-finite PIT values are invalid for KDE boundary correction method"
-    ))
-    x <- x[is.finite(x)]
-  }
-
   if (grid_len < 100) {
     grid_len <- 100
   }
@@ -819,6 +814,10 @@ ppc_loo_ribbon <-
   # 1-D Convolution
   bc_pvals <- .linear_convolution(x, bw, grid_counts, grid_breaks, grid_len)
 
+  if (all(is.na(bc_pvals))) {
+    abort("KDE boundary correction produced all NA values.")
+  }
+
   # Generate vector of x-axis values for plotting based on binned relative freqs
   n_breaks <- length(grid_breaks)