Merge pull request #173 from stan-dev/bugfix-issue-172

allow negative integer input to ppc_bars, ppc_bars_grouped

Author: jgabry

NEWS.md

@@ -41,7 +41,7 @@
   [`?ppc_loo_pit_overlay()`](http://mc-stan.org/bayesplot/reference/PPC-loo.html)
   now work as expected. (#166, #167)
 
-
+* `ppc_bars()` and `ppc_bars_grouped()` now allow negative integers as input. (#172)
 
 
 # bayesplot 1.6.0

R/helpers-ppc.R

@@ -234,7 +234,8 @@ ppc_group_data <- function(y, yrep, group, stat = NULL) {
   # grouping vars. It summarising path, it has one grouping var.
 }
 
-# check if x consists of whole numbers (very close to integers)
+# Check if x consists of whole numbers (very close to integers)
+# Implementation here follows example ?integer
 is_whole_number <- function(x, tol = .Machine$double.eps) {
   if (!is.numeric(x)) {
     FALSE
@@ -243,9 +244,13 @@ is_whole_number <- function(x, tol = .Machine$double.eps) {
   }
 }
 
-# check if all values in x are counts (non-negative whole numbers)
+# Check if all values in x are whole numbers or counts (non-negative whole
+# numbers)
+all_whole_number <- function(x, ...) {
+  all(is_whole_number(x, ...))
+}
 all_counts <- function(x, ...) {
-  all(is_whole_number(x, ...)) && min(x) >= 0
+  all_whole_number(x, ...) && min(x) >= 0
 }
 
 # labels ----------------------------------------------------------------

R/ppc-discrete.R

@@ -30,9 +30,10 @@
 #'
 #' @template return-ggplot
 #'
-#' @details For all of these plots \code{y} and \code{yrep} must be non-negative
-#'   integers, although they need not be integers in the strict sense of \R's
-#'   \code{\link{integer}} type.
+#' @details For all of these plots \code{y} and \code{yrep} must be
+#'   integers, although they need not be integers in the strict sense
+#'   of \R's \code{\link{integer}} type. For rootogram plots \code{y}
+#'   and \code{yrep} must also be non-negative.
 #'
 #' @section Plot Descriptions:
 #' \describe{
@@ -100,28 +101,37 @@ ppc_bars <-
            fatten = 3,
            freq = TRUE) {
 
-    check_ignored_arguments(...)
-    y <- validate_y(y)
-    yrep <- validate_yrep(yrep, y)
-    if (!all_counts(y))
-      stop("ppc_bars expects only non-negative integers in 'y'.")
-    if (!all_counts(yrep))
-      stop("ppc_bars expects only non-negative integers in 'yrep'.")
-
-    alpha <- (1 - prob) / 2
-    probs <- sort(c(alpha, 0.5, 1 - alpha))
-    yrep_data <- ppc_bars_yrep_data(y, yrep, probs = probs, freq = freq, group = NULL)
-    .ppc_bars(
-      y_data = data.frame(y = y),
-      yrep_data,
-      grouped = FALSE,
-      facet_args = list(),
-      width = width,
-      size = size,
-      fatten = fatten,
-      freq = freq
-    )
+  check_ignored_arguments(...)
+  y <- validate_y(y)
+  yrep <- validate_yrep(yrep, y)
+  if (!all_whole_number(y)) {
+    stop("ppc_bars expects 'y' to be discrete.")
   }
+  if (!all_whole_number(yrep)) {
+    stop("ppc_bars expects 'yrep' to be discrete.")
+  }
+
+  alpha <- (1 - prob) / 2
+  probs <- sort(c(alpha, 0.5, 1 - alpha))
+  yrep_data <- ppc_bars_yrep_data(
+    y,
+    yrep,
+    probs = probs,
+    freq = freq,
+    group = NULL
+  )
+
+  .ppc_bars(
+    y_data = data.frame(y = y),
+    yrep_data,
+    grouped = FALSE,
+    facet_args = list(),
+    width = width,
+    size = size,
+    fatten = fatten,
+    freq = freq
+  )
+}
 
 
 #' @rdname PPC-discrete
@@ -141,29 +151,31 @@ ppc_bars_grouped <-
            fatten = 3,
            freq = TRUE) {
 
-    check_ignored_arguments(...)
-    y <- validate_y(y)
-    yrep <- validate_yrep(yrep, y)
-    group <- validate_group(group, y)
-    if (!all_counts(y))
-      stop("ppc_bars expects only non-negative integers in 'y'.")
-    if (!all_counts(yrep))
-      stop("ppc_bars expects only non-negative integers in 'yrep'.")
-
-    alpha <- (1 - prob) / 2
-    probs <- sort(c(alpha, 0.5, 1 - alpha))
-    yrep_data <- ppc_bars_yrep_data(y, yrep, probs, freq = freq, group = group)
-    .ppc_bars(
-      y_data = data.frame(y, group),
-      yrep_data,
-      grouped = TRUE,
-      facet_args = facet_args,
-      width = width,
-      size = size,
-      fatten = fatten,
-      freq = freq
-    )
+  check_ignored_arguments(...)
+  y <- validate_y(y)
+  yrep <- validate_yrep(yrep, y)
+  group <- validate_group(group, y)
+  if (!all_whole_number(y)) {
+    stop("ppc_bars_grouped expects 'y' to be discrete.")
   }
+  if (!all_whole_number(yrep)) {
+    stop("ppc_bars_grouped expects 'yrep' to be discrete.")
+  }
+
+  alpha <- (1 - prob) / 2
+  probs <- sort(c(alpha, 0.5, 1 - alpha))
+  yrep_data <- ppc_bars_yrep_data(y, yrep, probs, freq = freq, group = group)
+  .ppc_bars(
+    y_data = data.frame(y, group),
+    yrep_data,
+    grouped = TRUE,
+    facet_args = facet_args,
+    width = width,
+    size = size,
+    fatten = fatten,
+    freq = freq
+  )
+}
 
 
 #' @rdname PPC-discrete

tests/testthat/test-extractors.R

@@ -4,10 +4,8 @@ context("Extractors")
 
 ITER <- 1000
 CHAINS <- 3
-capture.output(
-  fit <- stan_glm(mpg ~ wt + am, data = mtcars,
+fit <- stan_glm(mpg ~ wt + am, data = mtcars,
                   iter = ITER, chains = CHAINS, refresh = 0)
-)
 
 x <- list(cbind(a = 1:3, b = rnorm(3)), cbind(a = 1:3, b = rnorm(3)))
 

tests/testthat/test-ppc-discrete.R

@@ -30,11 +30,21 @@ test_that("freq argument to ppc_bars works", {
   expect_true(all(y_prop < 1) && all(y_prop > 0))
 })
 
-test_that("ppc_bars errors if y/yrep not natural numbers", {
+test_that("ppc_bars works with negative integers", {
+  y <- round(rnorm(100, -10, 1))
+  yrep <- round(matrix(rnorm(100 * 500, -10, 1), 500, 100))
+  expect_gg(ppc_bars(y, yrep))
+})
+
+test_that("ppc_bars(_grouped) errors if y/yrep not discrete", {
   expect_error(ppc_bars(y + 0.5, yrep),
-               "ppc_bars expects only non-negative integers in 'y'")
+               "ppc_bars expects 'y' to be discrete")
   expect_error(ppc_bars(y, yrep + 0.5),
-               "ppc_bars expects only non-negative integers in 'yrep'")
+               "ppc_bars expects 'yrep' to be discrete")
+  expect_error(ppc_bars_grouped(y + 0.5, yrep, group = esoph$agegp),
+               "ppc_bars_grouped expects 'y' to be discrete")
+  expect_error(ppc_bars_grouped(y, yrep + 0.5, group = esoph$agegp),
+               "ppc_bars_grouped expects 'yrep' to be discrete")
 })