Merge pull request #254 from stan-dev/fix-cran-issues

Fix CRAN issues

Author: jgabry

R/ppc-loo.R

@@ -172,7 +172,7 @@ ppc_loo_pit_overlay <- function(y,
       call. = FALSE
     )
   }
-  
+
   message(paste("NOTE: The kernel density estimate assumes continuous observations",
                 "and is not optimal for discrete observations."))
 
@@ -553,7 +553,7 @@ ppc_loo_ribbon <-
   attr(psis_object, "norm_const_log") <- attr(psis_object, "norm_const_log")[subset]
   attr(psis_object, "tail_len") <- attr(psis_object, "tail_len")[subset]
   attr(psis_object, "r_eff") <- attr(psis_object, "r_eff")[subset]
-  return(psis_object)
+  psis_object
 }
 
 ## Boundary correction based on code by ArViz development team
@@ -603,8 +603,7 @@ ppc_loo_ribbon <-
                             method = 'convolution',
                             sides = 2)[(npad + 1):(npad + grid_len)]
 
-  bc_pvals  <-  bc_pvals / (bw * (2 * pi)^0.5)
-  return(bc_pvals)
+  bc_pvals / (bw * (2 * pi)^0.5)
 }
 
 .kde_correction <- function(x,
@@ -625,12 +624,12 @@ ppc_loo_ribbon <-
 
   # Get relative frequency boundaries and counts for input vector
   bins <- seq(from= min(x), to = max(x), length.out = grid_len + 1)
-  hist_obj <- hist(x, breaks = bins, plot = FALSE)
+  hist_obj <- graphics::hist(x, breaks = bins, plot = FALSE)
   grid_breaks <- hist_obj$breaks
   grid_counts <- hist_obj$counts
 
   # Compute bandwidth based on use specification
-  bw <- density(x, bw = bw)$bw
+  bw <- stats::density(x, bw = bw)$bw
 
   # 1-D Convolution
   bc_pvals <- .linear_convolution(x, bw, grid_counts, grid_breaks, grid_len)
@@ -640,12 +639,12 @@ ppc_loo_ribbon <-
 
   xs <-  (grid_breaks[2:n_breaks] + grid_breaks[1:(n_breaks - 1)]) / 2
 
-  first_nonNA <- head(which(!is.na(bc_pvals)),1)
-  last_nonNA <- tail(which(!is.na(bc_pvals)),1)
+  first_nonNA <- utils::head(which(!is.na(bc_pvals)),1)
+  last_nonNA <- utils::tail(which(!is.na(bc_pvals)),1)
   bc_pvals[1:first_nonNA] <- bc_pvals[first_nonNA]
   bc_pvals[last_nonNA:length(bc_pvals)] <- bc_pvals[last_nonNA]
 
-  return(list(xs = xs, bc_pvals = bc_pvals))
+  list(xs = xs, bc_pvals = bc_pvals)
 }
 
 # Wrapper function to generate runif reference lines based on
@@ -669,5 +668,5 @@ ppc_loo_ribbon <-
     xs[idx[i]:(idx[i+1]-1)] <- bc_list$xs
   }
 
-  return(list(xs = xs, unifs = bc_mat))
+  list(xs = xs, unifs = bc_mat)
 }

tests/testthat.R

@@ -8,4 +8,3 @@ test_check("bayesplot")
 # pr <- testthat::ProgressReporter$new()
 # pr$max_fail = 1000
 # devtools::test(reporter = pr)
-

tests/testthat/test-convenience-functions.R

@@ -7,31 +7,39 @@ context("Convenience functions (for ggplot objects)")
 test_that("abline_01 returns the correct object", {
   expect_equal(
     abline_01(color = "green", linetype = 2),
-    geom_abline(intercept = 0, slope = 1, color = "green", linetype = 2, na.rm = TRUE)
+    geom_abline(intercept = 0, slope = 1, color = "green", linetype = 2, na.rm = TRUE),
+    check.environment = FALSE
   )
 })
 test_that("vline_* and hline_* return correct objects", {
   expect_equal(
     vline_0(color = "red"),
-    geom_vline(xintercept = 0, color = "red", na.rm = TRUE)
+    geom_vline(xintercept = 0, color = "red", na.rm = TRUE),
+    check.environment = FALSE
   )
   expect_equal(
     hline_0(size = 2, linetype = 3),
-    geom_hline(yintercept = 0, size = 2, linetype = 3, na.rm = TRUE)
+    geom_hline(yintercept = 0, size = 2, linetype = 3, na.rm = TRUE),
+    check.environment = FALSE
   )
   expect_equal(
     vline_at(c(3,4), na.rm = FALSE),
-    geom_vline(xintercept = c(3,4))
+    geom_vline(xintercept = c(3,4)),
+    check.environment = FALSE
   )
   expect_equal(
     hline_at(c(3,4), na.rm = FALSE),
-    geom_hline(yintercept = c(3,4))
+    geom_hline(yintercept = c(3,4)),
+    check.environment = FALSE
   )
 })
 test_that("vline_at with 'fun' works", {
   x <- example_mcmc_draws(chains = 1)
-  expect_equal(vline_at(x, colMeans),
-               geom_vline(xintercept = colMeans(x), na.rm = TRUE))
+  expect_equal(
+    vline_at(x, colMeans),
+    geom_vline(xintercept = colMeans(x), na.rm = TRUE),
+    check.environment = FALSE
+  )
 })
 test_that("calc_v (internal function) works", {
   a <- 1:4
@@ -176,8 +184,7 @@ test_that("overlay_function returns the correct object", {
   expect_error(overlay_function(), 'argument "fun" is missing')
   expect_equal(
     overlay_function(fun = "dnorm"),
-    stat_function(fun = "dnorm", inherit.aes = FALSE)
+    stat_function(fun = "dnorm", inherit.aes = FALSE),
+    check.environment = FALSE
   )
 })
-
-

tests/testthat/test-extractors.R

@@ -1,13 +1,13 @@
 library(bayesplot)
-suppressPackageStartupMessages(library(rstanarm))
 context("Extractors")
 
-ITER <- 1000
-CHAINS <- 3
-fit <- stan_glm(mpg ~ wt + am, data = mtcars,
-                iter = ITER, chains = CHAINS,
-                refresh = 0)
-
+if (requireNamespace("rstanarm", quietly = TRUE)) {
+  ITER <- 1000
+  CHAINS <- 3
+  fit <- rstanarm::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)))
 
 # nuts_params and log_posterior methods -----------------------------------
@@ -30,6 +30,8 @@ test_that("nuts_params.list parameter selection ok", {
 })
 
 test_that("all nuts_params methods identical", {
+  skip_if_not_installed("rstanarm")
+  skip_if_not_installed("rstan")
   expect_identical(
     nuts_params(fit),
     nuts_params(fit$stanfit)
@@ -41,6 +43,8 @@ test_that("all nuts_params methods identical", {
 })
 
 test_that("nuts_params.stanreg returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   np <- nuts_params(fit)
   expect_identical(colnames(np), c("Chain", "Iteration", "Parameter", "Value"))
 
@@ -53,13 +57,17 @@ test_that("nuts_params.stanreg returns correct structure", {
 })
 
 test_that("log_posterior.stanreg returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   lp <- log_posterior(fit)
   expect_identical(colnames(lp), c("Chain", "Iteration", "Value"))
   expect_equal(length(unique(lp$Iteration)), floor(ITER / 2))
   expect_equal(length(unique(lp$Chain)), CHAINS)
 })
 
 test_that("rhat.stanreg returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   r <- rhat(fit)
   expect_named(r)
   expect_equal(r, summary(fit)[1:length(r), "Rhat"])
@@ -69,6 +77,8 @@ test_that("rhat.stanreg returns correct structure", {
 })
 
 test_that("neff_ratio.stanreg returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   expect_named(neff_ratio(fit, pars = c("wt", "am")), c("wt", "am"))
 
   ratio <- neff_ratio(fit)
@@ -78,6 +88,8 @@ test_that("neff_ratio.stanreg returns correct structure", {
 })
 
 test_that("rhat.stanfit returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   r <- rhat(fit$stanfit)
   expect_named(r)
   expect_equal(r, summary(fit)[, "Rhat"])
@@ -88,6 +100,8 @@ test_that("rhat.stanfit returns correct structure", {
 })
 
 test_that("neff_ratio.stanreg returns correct structure", {
+  skip_if_not_installed("rstanarm")
+
   denom <- floor(ITER / 2) * CHAINS
 
   ratio <- neff_ratio(fit$stanfit)

tests/testthat/test-helpers-mcmc.R

@@ -241,13 +241,14 @@ test_that("prepare_mcmc_array processes non-array input types correctly", {
   expect_equal(parameter_names(a3), colnames(chainlist[[1]]))
 
   # object with acceptable as.array method
-  suppressPackageStartupMessages(library(rstanarm))
-  fit <- suppressWarnings(stan_glm(mpg ~ wt, data = mtcars, chains = 2, iter = 500, refresh = 0))
-  a4 <- prepare_mcmc_array(fit)
-  expect_s3_class(a4, "mcmc_array")
-  expect_equal(a4, prepare_mcmc_array(as.array(fit)))
-  expect_equal(dim(a4), c(250, 2, 3))
-  expect_equal(parameter_names(a4), c("(Intercept)", "wt", "sigma"))
+  if (requireNamespace("rstanarm", quietly = TRUE)) {
+    fit <- suppressWarnings(rstanarm::stan_glm(mpg ~ wt, data = mtcars, chains = 2, iter = 500, refresh = 0))
+    a4 <- prepare_mcmc_array(fit)
+    expect_s3_class(a4, "mcmc_array")
+    expect_equal(a4, prepare_mcmc_array(as.array(fit)))
+    expect_equal(dim(a4), c(250, 2, 3))
+    expect_equal(parameter_names(a4), c("(Intercept)", "wt", "sigma"))
+  }
 
   # object with unacceptable as.array method
   fit2 <- lm(mpg ~ wt, data = mtcars)

tests/testthat/test-mcmc-nuts.R

@@ -1,16 +1,18 @@
 library(bayesplot)
-suppressPackageStartupMessages(library(rstanarm))
 context("MCMC: nuts")
 
-ITER <- 1000
-CHAINS <- 3
-fit <- stan_glm(mpg ~ wt + am, data = mtcars,
-                iter = ITER, chains = CHAINS,
-                refresh = 0)
-np <- nuts_params(fit)
-lp <- log_posterior(fit)
+if (requireNamespace("rstanarm", quietly = TRUE)) {
+  ITER <- 1000
+  CHAINS <- 3
+  fit <- rstanarm::stan_glm(mpg ~ wt + am, data = mtcars,
+                            iter = ITER, chains = CHAINS,
+                            refresh = 0)
+  np <- nuts_params(fit)
+  lp <- log_posterior(fit)
+}
 
 test_that("all mcmc_nuts_* (except energy) return gtable objects", {
+  skip_if_not_installed("rstanarm")
   expect_gtable(mcmc_nuts_acceptance(np, lp))
   expect_gtable(mcmc_nuts_acceptance(np, lp, chain = CHAINS))
 
@@ -24,7 +26,9 @@ test_that("all mcmc_nuts_* (except energy) return gtable objects", {
   expect_gtable(mcmc_nuts_divergence(np, lp))
   expect_gtable(mcmc_nuts_divergence(np, lp, chain = CHAINS))
 })
+
 test_that("all mcmc_nuts_* (except energy) error if chain argument is bad", {
+  skip_if_not_installed("rstanarm")
   funs <- c("acceptance", "divergence", "treedepth", "stepsize")
   for (f in paste0("mcmc_nuts_", funs)) {
     expect_error(do.call(f, list(x=np, lp=lp, chain = CHAINS + 1)),
@@ -37,6 +41,8 @@ test_that("all mcmc_nuts_* (except energy) error if chain argument is bad", {
 })
 
 test_that("mcmc_nuts_energy returns a ggplot object", {
+  skip_if_not_installed("rstanarm")
+
   p <- mcmc_nuts_energy(np)
   expect_gg(p)
   expect_s3_class(p$facet, "FacetWrap")
@@ -46,12 +52,15 @@ test_that("mcmc_nuts_energy returns a ggplot object", {
   expect_gg(p)
   expect_s3_class(p$facet, "FacetNull")
 })
+
 test_that("mcmc_nuts_energy throws correct warnings", {
+  skip_if_not_installed("rstanarm")
   expect_warning(mcmc_nuts_energy(np, chain = 1), "ignored: chain")
 })
 
 
 test_that("validate_nuts_data_frame throws errors", {
+  skip_if_not_installed("rstanarm")
   expect_error(
     validate_nuts_data_frame(list(Iteration = 1, Chain = 1)),
     "NUTS parameters should be in a data frame"

tests/testthat/test-mcmc-recover.R

@@ -1,15 +1,18 @@
 library(bayesplot)
-suppressPackageStartupMessages(library(rstanarm))
 context("MCMC: recover")
 
-alpha <- 1; beta <- c(-.5, .5); sigma <- 2
-X <- matrix(rnorm(200), 100, 2)
-y <- rnorm(100, mean = c(alpha + X %*% beta), sd = sigma)
-fit <- stan_glm(y ~ ., data = data.frame(y, X), refresh = 0, iter = 750, chains = 2, seed = 8420)
-draws <- as.matrix(fit)
-true <- c(alpha, beta, sigma)
+if (requireNamespace("rstanarm", quietly = TRUE)) {
+  alpha <- 1; beta <- c(-.5, .5); sigma <- 2
+  X <- matrix(rnorm(200), 100, 2)
+  y <- rnorm(100, mean = c(alpha + X %*% beta), sd = sigma)
+  fit <- rstanarm::stan_glm(y ~ ., data = data.frame(y, X), refresh = 0, iter = 750, chains = 2, seed = 8420)
+  draws <- as.matrix(fit)
+  true <- c(alpha, beta, sigma)
+}
 
 test_that("mcmc_recover_intervals throws correct errors", {
+  skip_if_not_installed("rstanarm")
+
   expect_error(
     mcmc_recover_intervals(draws, letters[1:ncol(draws)]),
     "is.numeric(true) is not TRUE",
@@ -43,6 +46,8 @@ test_that("mcmc_recover_intervals throws correct errors", {
 })
 
 test_that("mcmc_recover_intervals returns a ggplot object", {
+  skip_if_not_installed("rstanarm")
+
   expect_gg(mcmc_recover_intervals(draws, true))
   expect_gg(mcmc_recover_intervals(draws, true, batch = c(1, 2, 2, 1),
                                    point_est = "mean"))
@@ -52,13 +57,17 @@ test_that("mcmc_recover_intervals returns a ggplot object", {
 })
 
 test_that("mcmc_recover_intervals works when point_est = 'none'", {
+  skip_if_not_installed("rstanarm")
+
   a <- mcmc_recover_intervals(draws, true, batch = 1:4, point_est = "none")
   expect_gg(a)
   expect_equal(a$data$Point, rep(NA, ncol(draws)))
 })
 
 
 test_that("mcmc_recover_scatter returns a ggplot object", {
+  skip_if_not_installed("rstanarm")
+
   expect_gg(
     mcmc_recover_scatter(draws, true)
   )
@@ -98,6 +107,8 @@ test_that("mcmc_recover_scatter returns a ggplot object", {
 
 
 test_that("mcmc_recover_hist returns a ggplot object", {
+  skip_if_not_installed("rstanarm")
+
   expect_gg(mcmc_recover_hist(draws, true))
   expect_gg(mcmc_recover_hist(draws, true, binwidth = .1,
                               facet_args = list(nrow = 1)))