tests/testthat/test-preddist.R

In RBesT: R Bayesian Evidence Synthesis Tools

## check that predictive distributions hold what they promise,
## i.e. that they describe the sum of n new data points.

set.seed(42343)

## precision at which reference and tested must match
eps <- 1e-2

## percentiles to test for
p_quants <- seq(0.1, 0.9, by = 0.1)

## number of samples used for sampling method
Nsamp <- 1e5

## define the different test cases
beta <- mixbeta(c(1, 11, 4))
betaMix <- mixbeta(c(0.8, 11, 4), c(0.2, 1, 1))

gamma <- mixgamma(c(1, 65, 50))
gammaMix <- mixgamma(rob = c(0.5, 8, 0.5), inf = c(0.5, 9, 2), param = "ms")

norm <- mixnorm(c(1, 0, 0.5), sigma = 1)
normMix <- mixnorm(c(0.2, 0, 2), c(0.8, 2, 1), sigma = 1)

n <- 25

preddist_cmp <- function(
  mix,
  n,
  n_rng,
  N = Nsamp,
  qntls = p_quants,
  stat = c("sum", "mean"),
  Teps = eps
) {
  skip_on_cran()

  ## sample for each draw a single hyper-parameter which is then
  ## used n times in the rng function to return n samples from the
  ## sampling distribution
  stat <- match.arg(stat)
  test <- replicate(N, n_rng(rmix(mix, 1)))
  if (stat == "sum") test_stat <- colSums(test)
  if (stat == "mean") test_stat <- colMeans(test)

  quants_stest <- quantile(test_stat, qntls)
  ## note: in particular for the discrete/counting distributions,
  ## sampling gives better estimates
  quants_sref <- qmix(preddist(mix, n = n), qntls)
  res_sum <- abs(quants_sref - quants_stest)
  ## note: errors are accumulating with n, hence to check the mean,
  ## we scale eps with n
  if (stat == "sum") expect_true(all(res_sum < n * Teps))
  if (stat == "mean") expect_true(all(res_sum < Teps))

  quants_test <- quantile(test[1, ], qntls)
  quants_ref <- qmix(preddist(mix, n = 1), qntls)
  res <- abs(quants_ref - quants_test)
  expect_true(all(res < Teps))

  if (inherits(mix, "betaMix")) {
    ## specifically test BetaBinomial (which is from Stan)
    predmix <- preddist(mix, n = 30)
    dens <- dmix(predmix, 0:30)
    cdens <- cumsum(dens)
    pc <- pmix(predmix, 0:30)
    upc <- pmix(predmix, 0:30, FALSE)
    expect_true(all(abs(cdens - pc) < Teps))
    expect_true(all(abs(1 - cdens - upc) < Teps))
  }

  ## test that output length of the predictive is the same as the
  ## input data vector, even for negative values for values outside
  ## the valid support of the postive only distribtions
  cprob_ltest <- pmix(preddist(mix, n = 1), c(-1, quants_ref))
  expect_true(length(cprob_ltest) == length(c(-1, quants_ref)))
}


test_that("Predictive for a beta evaluates correctly (binary)", {
  preddist_cmp(beta, n, Curry(rbinom, n = n, size = 1))
})
test_that("Predictive for a beta mixture evaluates correctly (binary)", {
  preddist_cmp(betaMix, n, Curry(rbinom, n = n, size = 1))
})

test_that("Predictive for a gamma evaluates correctly (poisson)", {
  preddist_cmp(gamma, n, Curry(rpois, n = n))
})
test_that("Predictive for a gamma mixture evaluates correctly (poisson)", {
  preddist_cmp(gammaMix, n, Curry(rpois, n = n), Teps = 1E-1)
})

test_that("Predictive for a normal evaluates correctly (normal)", {
  preddist_cmp(norm, n, Curry(rnorm, n = n, sd = sigma(norm)), stat = "mean")
})
test_that("Predictive for a normal mixture evaluates correctly (normal)", {
  preddist_cmp(
    normMix,
    n,
    Curry(rnorm, n = n, sd = sigma(normMix)),
    stat = "mean",
    Teps = 1E-1
  )
})