tests/testthat/test-collapse.R

In sdmTMB: Spatial and Spatiotemporal SPDE-Based GLMMs with 'TMB'

test_that("collapsing spatial and spatiotemporal fields works", {
  skip_on_cran()
  skip_on_ci()

  set.seed(123)
  predictor_dat <- data.frame(
    X = runif(1000), Y = runif(1000),
    a1 = rnorm(1000), year = sample(1:5, size = 1000, replace = TRUE)
  )
  mesh <- make_mesh(predictor_dat, xy_cols = c("X", "Y"), cutoff = 0.1)

  sim_dat <- sdmTMB_simulate(
    formula = ~ 1 + a1,
    data = predictor_dat,
    time = "year",
    mesh = mesh,
    family = tweedie(),
    range = 2,
    sigma_E = 0,
    phi = 0.2,
    sigma_O = 0,
    seed = 42,
    B = c(0.2, -0.4) # B0 = intercept, B1 = a1 slope
  )
  # create some fake 0s
  sim_dat$observed[sample(1:500, size = 50, replace = FALSE)] <- 0

  # test spatial collapse with gaussian family
  fit_nospatial <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off", spatial = "off",
    control = sdmTMBcontrol(collapse_spatial_variance = FALSE)
  )
  fit <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off",
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE)
  )
  expect_equal(tidy(fit_nospatial), tidy(fit))
  expect_equal(tidy(fit_nospatial, "ran_pars"), tidy(fit, "ran_pars"))
  expect_equal(tidy(fit_nospatial, "ran_vals"), tidy(fit, "ran_vals"))

  # test spatial / spatiotemporal collapse with spatiotemporal on
  fit_nospatial <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off", spatial = "off"
  )
  fit <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE)
  )
  expect_equal(tidy(fit_nospatial), tidy(fit))
  expect_equal(tidy(fit_nospatial, "ran_pars"), tidy(fit, "ran_pars"))
  expect_equal(tidy(fit_nospatial, "ran_vals"), tidy(fit, "ran_vals"))

  # test spatial collapse with delta family
  fit_nospatial <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off", spatial = "off", family = delta_gamma()
  )
  fit <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off", family = delta_gamma(),
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE)
  )
  expect_equal(tidy(fit_nospatial), tidy(fit))
  expect_equal(tidy(fit_nospatial, "ran_pars"), tidy(fit, "ran_pars"))
  expect_equal(tidy(fit_nospatial, "ran_vals"), tidy(fit, "ran_vals"))

  # test spatial / spatiotemporal collapse with delta family
  fit_nospatial <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatiotemporal = "off", spatial = "off", family = delta_gamma()
  )
  fit <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    family = delta_gamma(),
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE)
  )
  expect_equal(tidy(fit_nospatial), tidy(fit))
  expect_equal(tidy(fit_nospatial, "ran_pars"), tidy(fit, "ran_pars"))
  expect_equal(tidy(fit_nospatial, "ran_vals"), tidy(fit, "ran_vals"))
})

test_that("custom collapse threshold works", {
  skip_on_cran()

  set.seed(456)

  predictor_dat <- data.frame(
    X = runif(1000), Y = runif(1000),
    a1 = rnorm(1000), year = sample(1:5, size = 1000, replace = TRUE)
  )
  mesh <- make_mesh(predictor_dat, xy_cols = c("X", "Y"), cutoff = 0.1)

  sim_dat <- sdmTMB_simulate(
    formula = ~ 1 + a1,
    data = predictor_dat,
    time = "year",
    mesh = mesh,
    family = tweedie(),
    range = 2,
    sigma_E = 0.2,
    phi = 0.2,
    sigma_O = 0,
    seed = 43,
    B = c(0.2, -0.4)
  )

  # With 0.001, should not collapse
  fit_default <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatial = "off",
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE, collapse_threshold = 0.001)
  )

  # With higher threshold (0.3), should collapse
  fit_collapse <- sdmTMB(observed ~ a1,
    data = sim_dat, mesh = mesh, time = "year",
    spatial = "off",
    control = sdmTMBcontrol(collapse_spatial_variance = TRUE, collapse_threshold = 0.3)

  )

  expect_true(all(fit_default$spatiotemporal == "iid"))
  expect_true(all(fit_collapse$spatiotemporal == "off"))
})

test_that("collapse validation works", {
  # Test that collapse_threshold must be positive
  expect_error(
    sdmTMBcontrol(collapse_threshold = -0.01),
    "collapse_threshold not greater than 0"
  )

  expect_error(
    sdmTMBcontrol(collapse_threshold = 0),
    "collapse_threshold not greater than 0"
  )

  # Valid thresholds should work
  ctrl <- sdmTMBcontrol(collapse_threshold = 0.001)
  expect_equal(ctrl$collapse_threshold, 0.001)

  ctrl <- sdmTMBcontrol(collapse_threshold = 0.1)
  expect_equal(ctrl$collapse_threshold, 0.1)
})