Merge pull request #369 from stan-dev/ppc_stat

adding `discrete` argument to `stat` functions

Author: jgabry

NEWS.md

@@ -6,6 +6,7 @@
 * Add `x` argument to `ppc_error_binned` by @behramulukir (#359)
 * Add `x` argument to `ppc_error_scatter_avg()` by @behramulukir (#367)
 * Add `discrete` style to `ppc_rootogram` by @behramulukir (#362)
+* Add `discrete` argument to `ppc_stat` and `ppd_stat` by @behramulukir (#369)
 
 # bayesplot 1.13.0
 

R/ppc-discrete.R

@@ -77,6 +77,21 @@
 #' }
 #' }
 #'
+#' @section Related functions:
+#' In addition to the functions on this page that are restricted to discrete
+#' outcomes, some general PPC/PPD functions also support discrete data
+#' when requested:
+#' - [ppc_stat()] and [ppc_stat_grouped()] can visualize discrete test statistics
+#'    with predictive checks when `discrete = TRUE`.
+#' - [ppd_stat()] and [ppd_stat_grouped()] can visualize discrete test statistics
+#'    from predictive draws when `discrete = TRUE`.
+#' - [ppc_ecdf_overlay] can visualize empirical CDFs for discrete statistics
+#'    with `discrete = TRUE`.
+#' - [ppc_pit_ecdf()] and [ppc_pit_ecdf_grouped()] can also handle discrete
+#'   variables to plot PIT-ECDF of the empirical PIT values.
+#' These functions are not limited to discrete outcomes, but offer discrete-friendly
+#' displays for integer-valued statistics.
+#'
 #' @examples
 #' set.seed(9222017)
 #'

R/ppc-test-statistics.R

@@ -27,7 +27,8 @@
 #'   display the function name(s). If specified as a function (or functions)
 #'   then generic naming is used in the legend.
 #' @param ... Currently unused.
-#'
+#' @param discrete For `ppc_stat()` and `ppc_stat_grouped()`, if `TRUE` then a
+#'   bar chart is used instead of a histogram.
 #' @template details-binomial
 #' @template return-ggplot-or-data
 #'
@@ -38,7 +39,7 @@
 #' @section Plot Descriptions:
 #' \describe{
 #'   \item{`ppc_stat()`, `ppc_stat_freqpoly()`}{
-#'    A histogram or frequency polygon of the distribution of a statistic
+#'    A histogram/bar plot or frequency polygon of the distribution of a statistic
 #'    computed by applying `stat` to each dataset (row) in `yrep`. The value of
 #'    the statistic in the observed data, `stat(y)`, is overlaid as a vertical
 #'    line. More details and example usage of `ppc_stat()` can be found in Gabry
@@ -62,6 +63,12 @@
 #' ppc_stat(y, yrep, stat = "median")
 #' ppc_stat(y, yrep, stat = "sd") + legend_none()
 #'
+#' # discrete data example
+#' set.seed(0)
+#' y_discrete <- rbinom(20, 1, 0.2)
+#' yrep_discrete <- matrix(rbinom(2000, 1, prob = 0.4), 1000, 20, byrow = TRUE)
+#' ppc_stat(y_discrete, yrep_discrete, stat = "mean", discrete = TRUE)
+#'
 #' # use your own function for the 'stat' argument
 #' color_scheme_set("brightblue")
 #' q25 <- function(y) quantile(y, 0.25)
@@ -77,6 +84,10 @@
 #' ppc_stat_grouped(y, yrep, group, stat = "median")
 #' ppc_stat_grouped(y, yrep, group, stat = "mad") + yaxis_text()
 #'
+#' # discrete data example with groups
+#' group_discrete <- rep(c("First Half","Second Half"), each = 10)
+#' ppc_stat_grouped(y_discrete, yrep_discrete, group_discrete, stat = "mean", discrete = TRUE)
+#'
 #' # force y-axes to have same scales, allow x axis to vary
 #' ppc_stat_grouped(y, yrep, group, facet_args = list(scales = "free_x")) + yaxis_text()
 #'
@@ -106,6 +117,7 @@ ppc_stat <-
            yrep,
            stat = "mean",
            ...,
+           discrete = FALSE,
            binwidth = NULL,
            bins = NULL,
            breaks = NULL,
@@ -124,20 +136,32 @@ ppc_stat <-
       group = dots$group,
       stat = match.fun(stat)
     )
-    ggplot(
+
+    graph <- ggplot(
       data = dplyr::filter(data, .data$variable != "y"),
       mapping = set_hist_aes(freq)
-    ) +
-      geom_histogram(
+    )
+
+    graph <- if (discrete) {
+      graph + geom_bar(
+        aes(fill = "yrep"),
+        color = get_color("lh"),
+        linewidth = 0.25,
+        na.rm = TRUE,
+      )
+    } else {
+      graph + geom_histogram(
         aes(fill = "yrep"),
         color = get_color("lh"),
         linewidth = 0.25,
         na.rm = TRUE,
         binwidth = binwidth,
         bins = bins,
         breaks = breaks
-      ) +
-      geom_vline(
+      )
+    }
+
+    graph + geom_vline(
         data = dplyr::filter(data, .data$variable == "y"),
         mapping = aes(xintercept = .data$value, color = "y"),
         linewidth = 1.5
@@ -169,6 +193,7 @@ ppc_stat_grouped <-
            group,
            stat = "mean",
            ...,
+           discrete = FALSE,
            facet_args = list(),
            binwidth = NULL,
            bins = NULL,

R/ppd-test-statistics.R

@@ -35,6 +35,7 @@ ppd_stat <-
   function(ypred,
            stat = "mean",
            ...,
+           discrete = FALSE,
            binwidth = NULL,
            bins = NULL,
            breaks = NULL,
@@ -51,18 +52,28 @@ ppd_stat <-
       group = dots$group,
       stat = match.fun(stat)
     )
-    ggplot(data, mapping = set_hist_aes(
+    graph <- ggplot(data, mapping = set_hist_aes(
       freq,
       color = "ypred",
       fill = "ypred"
-    )) +
+    ))
+    graph <- graph + if (discrete) {
+      geom_bar(
+        color = get_color("lh"),
+        linewidth = 0.25,
+        na.rm = TRUE,
+        position = "identity",
+      )
+    }
+    else {
       geom_histogram(
         linewidth = 0.25,
         na.rm = TRUE,
         binwidth = binwidth,
         bins = bins,
         breaks = breaks
-      ) +
+      ) }
+      graph +
       scale_color_ppd(guide = "none") +
       scale_fill_ppd(labels = Typred_label(), guide = guide_legend(
         title = stat_legend_title(stat, deparse(substitute(stat)))
@@ -83,6 +94,7 @@ ppd_stat_grouped <-
            group,
            stat = "mean",
            ...,
+           discrete = FALSE,
            facet_args = list(),
            binwidth = NULL,
            bins = NULL,