tests/testthat/test-arguments.R

In AdMit: Adaptive Mixture of Student-t Distributions

## Argument handling and optimizer plumbing that used to fail silently.

test_that("AdMit warns about unknown control components", {
  expect_warning(
    AdMit(KERNEL = GelmanMeng, mu0 = c(0.0, 0.1),
          control = list(Ns = 5e3, Np = 5e2, Hmax = 2, Hmaxx = 99)),
    "unknown names in 'control': Hmaxx")
})

test_that("AdMit does not warn about valid control components", {
  expect_no_warning(
    AdMit(KERNEL = GelmanMeng, mu0 = c(0.0, 0.1),
          control = list(Ns = 5e3, Np = 5e2, Hmax = 2, CVtol = 0.2, df = 5)))
})

test_that("AdMitIS warns about arguments used by neither KERNEL nor G", {
  set.seed(501)
  fit <- AdMit(KERNEL = GelmanMeng, mu0 = c(0.0, 0.1),
               control = list(Ns = 5e3, Np = 5e2, Hmax = 2))

  expect_warning(AdMitIS(N = 1e3, KERNEL = GelmanMeng, mit = fit$mit, notanarg = 1),
                 "used by neither 'KERNEL' nor 'G'")
  ## arguments that do belong to KERNEL or to G must not warn
  expect_no_warning(AdMitIS(N = 1e3, KERNEL = GelmanMeng, mit = fit$mit, A = 2))
  expect_no_warning(AdMitIS(N = 1e3, KERNEL = GelmanMeng, mit = fit$mit,
                            G = function(theta, shift) theta - shift, shift = 1))
})

test_that("AdMitIS routes abbreviated argument names to the right function", {
  ## the dispatch used to select from '...' by the *matched formal* name, so an
  ## abbreviated name resolved to a name absent from the supplied arguments
  Scaled <- function(x, scaling = 1, log = TRUE) {
    if (is.vector(x)) x <- matrix(x, nrow = 1)
    r <- -0.5 * scaling * (x[,1]^2 + x[,2]^2)
    if (!log) r <- exp(r)
    as.vector(r)
  }
  set.seed(502)
  fit <- AdMit(KERNEL = Scaled, mu0 = c(0.1, 0.1), scaling = 4,
               control = list(Ns = 5e3, Np = 5e2, Hmax = 2))

  set.seed(503)
  full <- AdMitIS(N = 5e3, KERNEL = Scaled, mit = fit$mit, scaling = 4)
  set.seed(503)
  abbr <- AdMitIS(N = 5e3, KERNEL = Scaled, mit = fit$mit, scal = 4)
  expect_equal(abbr$ghat, full$ghat)

  ## same for an abbreviated formal of G
  G.shift <- function(theta, shiftvalue) theta - shiftvalue
  set.seed(504)
  a <- AdMitIS(N = 5e3, KERNEL = Scaled, mit = fit$mit, scaling = 4,
               G = G.shift, shiftvalue = 1)
  set.seed(504)
  b <- AdMitIS(N = 5e3, KERNEL = Scaled, mit = fit$mit, scaling = 4,
               G = G.shift, shift = 1)
  expect_equal(a$ghat, b$ghat)
})

test_that("the gradient belongs to the point it is asked about", {
  ## The gradient handed to the optimizer used to be whatever the last
  ## *objective* evaluation left behind, so asking for g(B) right after f(A)
  ## returned the gradient at A. That is silent and only bites when the
  ## optimizer breaks the f-then-g-at-the-same-point pattern, so it has to be
  ## tested on the evaluator itself rather than through the optimizer.
  set.seed(505)
  Np <- 40L; H <- 3L
  lnK <- matrix(rnorm(Np * H), Np, H)
  lnD <- matrix(rnorm(Np * H * H, -1, 0.5), Np, H * H)

  lnfgrad <- get("fn.lnfgrad", envir = asNamespace("AdMit"))
  lambdaA <- c(0.7, -0.4)
  lambdaB <- c(-0.2, 1.1)

  ## reference: an evaluator that has only ever seen lambdaB
  ref <- lnfgrad(lnK, lnD)
  ref$f(lambdaB)
  gB <- ref$g(lambdaB)

  ## the same gradient, requested straight after an objective call elsewhere
  obj <- lnfgrad(lnK, lnD)
  obj$f(lambdaA)
  expect_equal(obj$g(lambdaB), gB)

  ## and with no objective call at all beforehand
  expect_equal(lnfgrad(lnK, lnD)$g(lambdaB), gB)

  ## the gradient is the actual derivative of the objective at that point
  num <- vapply(seq_along(lambdaB), function(j) {
    h <- 1e-6
    lp <- lm <- lambdaB
    lp[j] <- lambdaB[j] + h
    lm[j] <- lambdaB[j] - h
    (ref$f(lp) - ref$f(lm)) / (2 * h)
  }, numeric(1))
  expect_equal(gB, num, tolerance = 1e-6)
})

test_that("fn.optp returns a valid probability vector and is deterministic", {
  set.seed(506)
  Np <- 40L; H <- 3L
  lnK <- matrix(rnorm(Np * H), Np, H)
  lnD <- matrix(rnorm(Np * H * H, -1, 0.5), Np, H * H)
  ctl <- list(trace = 0, iter.max = 5e2, rel.tol = 1e-8, weightNC = 0.1)

  optp <- get("fn.optp", envir = asNamespace("AdMit"))
  out <- optp(c(0.5, 0.5), lnK, lnD, ctl)

  expect_length(out$p, H)
  expect_equal(sum(out$p), 1)
  expect_true(all(out$p > 0))
  expect_equal(optp(c(0.5, 0.5), lnK, lnD, ctl)$p, out$p)
})

test_that("fn.wIS centres every candidate on the highest-weight draw", {
  set.seed(507)
  theta <- matrix(rnorm(200), 100, 2)
  w <- runif(100)
  wIS <- get("fn.wIS", envir = asNamespace("AdMit"))
  out <- wIS(theta, w, list(percent = c(.05, .15, .3), scale = c(1, .25, 4)))

  expect_equal(out$mu, theta[which.max(w), ], ignore_attr = TRUE)
  expect_identical(dim(out$Sigma), c(9L, 4L)) ## 3 percentages x 3 scalings
  ## the scalings are applied to a common scale matrix, in order
  expect_equal(out$Sigma[2, ], 0.25 * out$Sigma[1, ])
  expect_equal(out$Sigma[3, ], 4 * out$Sigma[1, ])
})