tests/testthat/test-mvhyper.R

In ghypernet: Fit and Simulate Generalised Hypergeometric Ensembles of Graphs

test_that("dmvhyper_base returns 0 / -Inf for invalid x (support checks)", {
  n <- c(10L, 5L, 7L)
  k <- 8L
  
  x1 <- c(-1L, 2L, 7L)
  expect_identical(dmvhyper_base(x1, n, k, log = FALSE), 0)
  expect_identical(dmvhyper_base(x1, n, k, log = TRUE), -Inf)
  
  x2 <- c(11L, 0L, -3L)
  expect_identical(dmvhyper_base(x2, n, k, log = FALSE), 0)
  expect_identical(dmvhyper_base(x2, n, k, log = TRUE), -Inf)
  
  x3 <- c(1L, 1L, 1L) # sum=3, k=8
  expect_identical(dmvhyper_base(x3, n, k, log = FALSE), 0)
  expect_identical(dmvhyper_base(x3, n, k, log = TRUE), -Inf)
  
  expect_identical(dmvhyper_base(c(1L, 1L, 1L), n, k = 100L, log = TRUE), -Inf)
  expect_identical(dmvhyper_base(c(1L, 1L, 1L), n, k = 100L, log = FALSE), 0)
})

test_that("dmvhyper_base matches the closed-form formula on valid inputs", {
  n <- c(10L, 5L, 7L)
  x <- c(3L, 2L, 3L)
  k <- sum(x)
  
  lp_expected <- sum(lchoose(n, x)) - lchoose(sum(n), k)
  expect_equal(dmvhyper_base(x, n, k, log = TRUE), lp_expected, tolerance = 0)
  expect_equal(dmvhyper_base(x, n, k, log = FALSE), exp(lp_expected), tolerance = 0)
})

test_that("dmvhyper_base handles edge cases: k=0 and single-category", {
  # k = 0
  n <- c(4L, 9L, 2L)
  x <- c(0L, 0L, 0L)
  expect_equal(dmvhyper_base(x, n, k = 0L, log = TRUE), 0, tolerance = 0)
  expect_equal(dmvhyper_base(x, n, k = 0L, log = FALSE), 1, tolerance = 0)
  
  # single category => deterministic
  n1 <- 10L
  k1 <- 7L
  x1 <- 7L
  expect_equal(dmvhyper_base(x1, n1, k = k1, log = FALSE), 1, tolerance = 0)
  expect_equal(dmvhyper_base(x1, n1, k = k1, log = TRUE), 0, tolerance = 0)
  
  # invalid for single category
  expect_identical(dmvhyper_base(8L, n1, k = k1, log = FALSE), 0)
  expect_identical(dmvhyper_base(8L, n1, k = k1, log = TRUE), -Inf)
})

test_that("rmvhyper_base outputs valid samples (nonnegative, within n, correct row sums)", {
  set.seed(1)
  
  n <- c(5L, 10L, 20L, 0L, 7L)
  k <- 12L
  nn <- 500L
  
  x <- rmvhyper_base(nn = nn, n = n, k = k)
  
  expect_true(is.matrix(x))
  expect_identical(ncol(x), length(n))
  expect_identical(nrow(x), nn)
  
  expect_true(all(x >= 0))
  expect_true(all(t(t(x) <= n)))
  expect_true(all(rowSums(x) == k))
})

test_that("rmvhyper_base handles edge cases deterministically", {
  n <- c(5L, 10L, 3L)
  
  # nn = 0
  x0 <- rmvhyper_base(nn = 0L, n = n, k = 4L)
  expect_true(is.matrix(x0))
  expect_identical(nrow(x0), 0L)
  expect_identical(ncol(x0), length(n))
  
  # k = 0 => all zeros
  xk0 <- rmvhyper_base(nn = 10L, n = n, k = 0L)
  expect_true(all(xk0 == 0L))
  
  # single category => always k
  x1 <- rmvhyper_base(nn = 12L, n = 10L, k = 7L)
  expect_true(all(x1[, 1] == 7L))
  
  # k == sum(n) => always n
  xall <- rmvhyper_base(nn = 8L, n = n, k = sum(n))
  expect_true(all(xall == rep(n, each = 8L)))
})

test_that("rmvhyper_base marginal means are close to expectation", {
  set.seed(42)
  
  n <- c(15L, 25L, 10L, 50L)
  N <- sum(n)
  k <- 30L
  nn <- 40000L
  
  x <- rmvhyper_base(nn = nn, n = n, k = k)
  
  mu <- k * (n / N)
  # Hypergeom marginal variance
  var <- k * (n / N) * (1 - n / N) * ((N - k) / (N - 1))
  se <- sqrt(var / nn)
  
  expect_true(all(abs(colMeans(x) - mu) <= 6 * se + 0.02))
})