tests/testthat/test-cf_dglm.R

In spCF: Coarse-to-Fine Spatial and Spatio-Temporal Modeling

s <- sim_spacetime(ns = 50, nt = 4)

test_that("cf_dglm fits a space-time model and predicts at new sites", {
  hv <- quiet(cf_dglm_hv(y = s$y, x = s$x, coords = s$coords, time = s$time))
  expect_s3_class(hv, "cf_dglm_hv")
  expect_output(print(hv))

  m <- quiet(cf_dglm(y = s$y, x = s$x, coords = s$coords, time = s$time,
                     x0 = s$x[seq_len(s$ns), , drop = FALSE],
                     coords0 = s$coords_uni, time0 = rep(s$nt, s$ns),
                     mod_hv = hv))
  expect_s3_class(m, "cf_dglm")
  expect_true(all(is.finite(as.matrix(m$beta))))
  expect_equal(nrow(m$pred), length(s$y))
  expect_equal(nrow(m$pred0), s$ns)
  expect_true(all(is.finite(m$pred0$pred)))
  expect_gt(cor(m$pred$pred, s$y), 0.5)
  expect_output(print(m))
})

test_that("coords0 without time0 is refused", {
  hv <- quiet(cf_dglm_hv(y = s$y, x = s$x, coords = s$coords, time = s$time))
  expect_error(quiet(cf_dglm(y = s$y, x = s$x, coords = s$coords, time = s$time,
                             x0 = s$x[seq_len(s$ns), , drop = FALSE],
                             coords0 = s$coords_uni, mod_hv = hv)),
               "time0")
})

test_that("Poisson space-time fits stay non-negative", {
  set.seed(21)
  y <- rpois(length(s$y), exp(pmin(rep(s$field, s$nt), 2)))
  hv <- quiet(cf_dglm_hv(y = y, x = s$x, coords = s$coords, time = s$time,
                         family = poisson()))
  m  <- quiet(cf_dglm(y = y, x = s$x, coords = s$coords, time = s$time,
                      mod_hv = hv))
  expect_true(all(m$pred$pred >= 0))
})

test_that("fixed rho/Q and time-varying coefficients are accepted", {
  hv_fixed <- quiet(cf_dglm_hv(y = s$y, x = s$x, coords = s$coords,
                               time = s$time, rho = 0.8, Q = 1))
  expect_s3_class(hv_fixed, "cf_dglm_hv")
  hv_tvc <- quiet(cf_dglm_hv(y = s$y, x = s$x, coords = s$coords,
                             time = s$time, tvc = "v1"))
  expect_s3_class(hv_tvc, "cf_dglm_hv")
})

test_that("negbin() and poisson(identity) space-time fits", {
  s <- sim_spacetime(ns = 40, nt = 4, seed = 31)
  set.seed(31)
  mu <- exp(0.5 + 0.4 * rep(s$field, s$nt))
  y  <- rnbinom(length(mu), size = 2, mu = mu)
  hv <- quiet(cf_dglm_hv(y = y, x = s$x, coords = s$coords, time = s$time,
                         family = negbin()))
  expect_true(is.finite(hv$other$family$theta) && hv$other$family$theta > 0)
  m  <- quiet(cf_dglm(y = y, x = s$x, coords = s$coords, time = s$time, mod_hv = hv))
  expect_true(all(m$pred$pred > 0) && all(is.finite(m$pred$pred_sd)))
  yi <- rpois(length(mu), 2 + 0.5 * rep(s$field, s$nt))
  hi <- quiet(cf_dglm_hv(y = yi, x = s$x, coords = s$coords, time = s$time,
                         family = poisson(link = "identity")))
  mi <- quiet(cf_dglm(y = yi, x = s$x, coords = s$coords, time = s$time, mod_hv = hi))
  expect_true(all(mi$pred$pred > 0) && all(is.finite(mi$pred$pred_sd)))
})

test_that("Gamma space-time fits get an observation predictive", {
  s <- sim_spacetime(ns = 40, nt = 4, seed = 32)
  set.seed(32)
  mu <- exp(0.3 + 0.4 * rep(s$field, s$nt))
  y  <- rgamma(length(mu), shape = 4, rate = 4 / mu)
  hv <- quiet(cf_dglm_hv(y = y, x = s$x, coords = s$coords, time = s$time,
                         family = Gamma(link = "log")))
  m  <- quiet(cf_dglm(y = y, x = s$x, coords = s$coords, time = s$time, mod_hv = hv))
  expect_identical(m$other$calibration$type, "gamma_moment")
  expect_true(all(is.finite(m$pred$pred_sd)) && all(m$pred$pred_sd > 0))
})