tests/testthat/test-DirichletDistribution.R

In rdecision: Decision Analytic Modelling in Health Economics

test_that("illegal initializations are rejected", {
  alpha <- c(2.0, 6.0)
  expect_silent(DirichletDistribution$new(alpha))
  expect_error(DirichletDistribution$new(2.0), class = "alpha_unsupported")
  expect_error(
    DirichletDistribution$new(c("0.5", 2.0)), class = "alpha_not_numeric"
  )
  expect_error(
    DirichletDistribution$new(c(2.0, NA_real_)), class = "alpha_not_defined"
  )
  expect_error(
    DirichletDistribution$new(c(2.0, 0.0)), class = "alpha_unsupported"
  )
  expect_error(
    DirichletDistribution$new(c(2.0, -1.0)), class = "alpha_unsupported"
  )
})

test_that("order is returned correctly", {
  alpha <- c(2.0, 6.0)
  D <- DirichletDistribution$new(alpha)
  expect_identical(D$order(), 2L)
  alpha <- c(3.0, 12.0, 9.0)
  D <- DirichletDistribution$new(alpha = alpha)
  expect_identical(D$order(), 3L)
})

test_that("the correct distribution name is created", {
  alpha <- c(2.0, 6.0)
  D <- DirichletDistribution$new(alpha)
  expect_identical(D$distribution(), "Dir(2,6)")
})

test_that("mean is calculated correctly", {
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  m <- D$mean()
  expect_identical(m, c(1L / 8L, 1L / 2L, 3L / 8L))
})

test_that("mode is calculated correctly", {
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  m <- D$mode()
  expect_identical(m, c(2L / 21L, 11L / 21L, 8L / 21L))
  #
  alpha <- c(3.0, 0.5, 9.0)
  D <- DirichletDistribution$new(alpha = alpha)
  m <- D$mode()
  expect_true(all(is.na(m)))
})

test_that("SD is NA for a multivariate distribution", {
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  expect_length(D$SD(), 3L)
  expect_true(all(is.na(D$SD())))
})

test_that("quantile function checks inputs and has correct output", {
  alpha <- c(3L, 12L, 9L)
  x <- DirichletDistribution$new(alpha = alpha)
  probs <- c(0.1, 0.2, 0.5)
  expect_silent(x$quantile(probs))
  probs <- c(0.1, NA_real_, 0.5)
  expect_error(x$quantile(probs), class = "probs_not_defined")
  probs <- c(0.1, "boo", 0.5)
  expect_error(x$quantile(probs), class = "probs_not_numeric")
  probs <- c(0.1, 0.4, 1.5)
  expect_error(x$quantile(probs), class = "probs_out_of_range")
  probs <- c(0.1, 0.2, 0.5, 0.9)
  q <- x$quantile(probs)
  expect_true(is.matrix(q))
  expect_identical(ncol(q), 3L)
  expect_identical(nrow(q), 4L)
})

test_that("marginal quantiles are from Beta distributions", {
  # create distribution
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  # test single quantile
  Q <- D$quantile(0.5)
  qm <- stats::qbeta(p = 0.5, shape1 = 3L, shape2 = 21L)
  expect_identical(unname(qm), Q["0.5", "1"])
  # test UQ and LQ in 3D
  p <- c(0.25, 0.75)
  Q <- D$quantile(p)
  expect_true(is.matrix(Q))
  q1 <- stats::qbeta(p, shape1 = 3L, shape2 = 21L)
  expect_identical(q1, unname(Q[, "1"]))
  q2 <- stats::qbeta(p, shape1 = 12L, shape2 = 12L)
  expect_identical(q2, unname(Q[, "2"]))
  q3 <- stats::qbeta(p, shape1 = 9L, shape2 = 15L)
  expect_identical(q3, unname(Q[, "3"]))
})

test_that("variance-covariance matrix is calculated correctly", {
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  VC <- D$varcov()
  expect_true(is.matrix(VC))
  expect_identical(nrow(VC), 3L)
  expect_identical(ncol(VC), 3L)
  VCE <- matrix(
    c(7L / 64L, -1L / 16L, -3L / 64L,
      -1L / 16L, 1L / 4L, -3L / 16L,
      -3L / 64L, -3L / 16L, 15L / 64L
    ),
    nrow = 3L,
    ncol = 3L,
    byrow = TRUE
  )
  VCE <- VCE / 25L
  expect_intol(sum(VC - VCE), 0.0, tolerance = 0.0001)
})

test_that("random sampling is from a Dirichlet distribution", {
  # create a distribution
  alpha <- c(3L, 12L, 9L)
  D <- DirichletDistribution$new(alpha = alpha)
  # test that means are provided at first call to r() without sampling
  samp <- D$r()
  expect_identical(samp, c(1L / 8L, 1L / 2L, 3L / 8L))
  # test that sample argument works
  D$sample()
  D$sample(expected = TRUE)
  samp <- D$r()
  expect_identical(samp, c(1L / 8L, 1L / 2L, 3L / 8L))
  # sample from it
  n <- 1000L
  osamp <- matrix(nrow = n, ncol = 3L)
  for (i in seq_len(n)) {
    D$sample()
    osamp[i, ] <- D$r()
  }
  expect_identical(nrow(osamp), n)
  expect_identical(ncol(osamp), 3L)
  expect_identical(sum(is.na(osamp)), 0L)
  # check that marginal distributions are Beta(). Use 99.9% confidence limits;
  # expected test failure rate is 0.1%;
  # skip for CRAN
  skip_on_cran()
  marg1 <- rbeta(n, shape1 = alpha[[1L]], shape2 = sum(alpha) - alpha[[1L]])
  marg2 <- rbeta(n, shape1 = alpha[[2L]], shape2 = sum(alpha) - alpha[[2L]])
  marg3 <- rbeta(n, shape1 = alpha[[3L]], shape2 = sum(alpha) - alpha[[3L]])
  ht <- ks.test(osamp[, 1L], marg1)
  expect_gt(ht$p.value, 0.001)
  ht <- ks.test(osamp[, 2L], marg2)
  expect_gt(ht$p.value, 0.001)
  ht <- ks.test(osamp[, 3L], marg3)
  expect_gt(ht$p.value, 0.001)
})