tests/testthat/test-gamma-bounds.R

In exdqlm: Extended Dynamic Quantile Linear Models

# Reference R implementation (legacy) for comparison in tests
.log_g_ref <- function(gam) {
  base::log(2) + stats::pnorm(-abs(gam), log = TRUE) + 0.5 * gam^2
}
.L_ref <- function(p0) {
  stats::uniroot(function(gam) exp(.log_g_ref(gam)) - (1 - p0), c(-1000, 0))$root
}
.U_ref <- function(p0) {
  stats::uniroot(function(gam) exp(.log_g_ref(gam)) - p0, c(0, 1000))$root
}


test_that("get_gamma_bounds sane at p0=0.5", {
  b <- get_gamma_bounds(0.5)
  expect_length(b, 2)
  expect_true(all(is.finite(b)))
  expect_true(b["L"] < b["U"])
  expect_lt(abs(b["L"]), 10)
  expect_lt(abs(b["U"]), 10)
  expect_lt(abs(b["L"] + b["U"]), 1e-3)

  ref <- c(L = .L_ref(0.5), U = .U_ref(0.5))
  expect_equal(unname(b), unname(ref), tolerance = 1e-3)
})

test_that("get_gamma_bounds works at extreme p0 (regression)", {
  for (p0 in c(0.001, 0.994170922668371)) {
    b <- get_gamma_bounds(p0)
    expect_length(b, 2)
    expect_true(all(is.finite(b)))
    expect_true(b["L"] < b["U"])
    expect_true(b["L"] <= 0)
    expect_true(b["U"] >= 0)

    ref <- c(L = .L_ref(p0), U = .U_ref(p0))
    expect_equal(unname(b), unname(ref), tolerance = 1e-3)

    # C++ wrapper should agree with the reference as well.
    cpp <- exdqlm:::get_gamma_bounds_cpp(p0)
    expect_true(all(is.finite(cpp)))
    expect_true(cpp["L"] < cpp["U"])
    expect_equal(unname(cpp), unname(ref), tolerance = 1e-3)
  }
})


test_that("get_gamma_bounds finite and ordered on grid", {
  pgrid <- c(seq(0.01, 0.99, by = 0.01), 0.001, 1 - 0.001)
  for (p0 in pgrid) {
    b <- get_gamma_bounds(p0)
    expect_true(all(is.finite(b)))
    expect_true(b["L"] < b["U"])
    expect_true(b["L"] <= 0)
    expect_true(b["U"] >= 0)

    # Validate against defining equations on log-scale (stable for extremes).
    expect_lt(abs(.log_g_ref(b["L"]) - log1p(-p0)), 1e-3)
    expect_lt(abs(.log_g_ref(b["U"]) - log(p0)), 1e-3)
  }
})


test_that("get_gamma_bounds stable under repeated calls", {
  set.seed(123)
  p0s <- stats::runif(50, min = 0.001, max = 1 - 0.001)
  for (p0 in p0s) {
    b <- get_gamma_bounds(p0)
    expect_true(all(is.finite(b)))
    expect_true(b["L"] < b["U"])
    expect_lt(abs(.log_g_ref(b["L"]) - log1p(-p0)), 1e-3)
    expect_lt(abs(.log_g_ref(b["U"]) - log(p0)), 1e-3)
  }
})


test_that("ISVB/MCMC reach bounds path on tiny model", {
  # Minimal exdqlm model
  model <- as.exdqlm(list(m0 = 0, C0 = matrix(1, 1, 1), FF = 1, GG = 1))
  y <- c(0.1, -0.2)

  old_opts <- options(exdqlm.use_cpp_kf = FALSE, exdqlm.compute_elbo = FALSE)
  on.exit(options(old_opts), add = TRUE)

  expect_silent(
    exdqlmISVB(y, p0 = 0.5, model = model, df = 1, dim.df = 1,
              sig.init = 1, n.IS = 2, n.samp = 2, tol = 1e6, verbose = FALSE)
  )

  expect_silent(
    exdqlmMCMC(y, p0 = 0.5, model = model, df = 1, dim.df = 1,
              Sig.mh = diag(c(0.005, 0.005)), n.burn = 0, n.mcmc = 1,
              init.from.isvb = FALSE, verbose = FALSE)
  )
})