tests/testthat/test-sdmTMB-simulate.R

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

test_that("sdmTMB_simulate works for different spatiotemporal field types", {
  skip_on_cran()

  # make fake predictor(s) (a1) and sampling locations:
  set.seed(123)
  predictor_dat <- data.frame(
    X = runif(2000), Y = runif(2000),
    a1 = rnorm(2000), year = rep(1:10, each = 200)
  )

  cutoff <- 0.1
  sim_mesh <- sdmTMB::make_mesh(predictor_dat, xy_cols = c("X", "Y"), cutoff = cutoff)
  plot(sim_mesh)

  fe_default <- 0.5
  range_default <- 0.3
  sigma_default <- 0.1

  test_sim <- function(b0 = 0.5,
                       b1 = -fe_default,
                       phi = 0.1,
                       mtrange = range_default,
                       rho = NULL,
                       sigma_O = sigma_default,
                       sigma_E = sigma_default,
                       model_type = "IID") {

    sim_dat <- sdmTMB::sdmTMB_simulate(
      formula = ~ 1 + a1,
      data = predictor_dat,
      time = "year",
      mesh = sim_mesh,
      family = gaussian(),
      range = mtrange,
      rho = rho,
      sigma_O = sigma_O,
      sigma_E = sigma_E,
      phi = phi,
      seed = 42,
      B = c(b0, b1) # B0 = intercept, B1 = a1 slope
    )

    fit <- sdmTMB::sdmTMB(observed ~ a1,
      data = sim_dat, mesh = sim_mesh, time = "year",
      spatiotemporal = model_type
    )

    if (all(unlist(sanity(fit, gradient_thresh = 0.01)))) {
      sr <- as.list(fit$sd_report, "Estimate")
      ty <- tidy(fit, effects = "ran_pars", conf.int = TRUE, silent = TRUE)
      out <- list()
      out[["model"]] <- fit

      # calculate the difference between estimate and true
      out["b0"] <- sr$b_j[1] - b0
      out["b1"] <- sr$b_j[2] - b1
      out["phi"] <- exp(sr$ln_phi[1]) - phi
      out["range"] <- ty$estimate[ty$term == "range"] - mtrange
      out["rho"] <- ifelse(is.null(rho), 0,
                           ty$estimate[ty$term == "rho"] - rho)
      out["sigma_O"] <- ty$estimate[ty$term == "sigma_O"] - sigma_O
      out["sigma_E"] <- ifelse(is.null(sigma_E), 0,
                               ty$estimate[ty$term == "sigma_E"] - sigma_E)
      out
    } else {
      out <- list()
      out[["model"]] <- fit
      out
    }
  }

  # tests with IID
  # fixed_effect_default 0.7
  # range = 0.4
  # phi = 0.1
  # sigmas = 0.1
  # mesh uncertainty/cutoff = 0.1
  t1 <- test_sim()
  t1[[1]]
  # fixed effect within 5% of true value
  expect_lt(abs(t1[["b1"]]), fe_default*0.05)
  # range error within 0.1 mesh cutoff
  expect_lt(abs(t1[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t1[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_E"])

  # increase sigma_O
  t <- test_sim(sigma_O = 0.4, sigma_E = 0.1)
  t[[1]]
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(0.4, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(0.4, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(0.1, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(0.1, ci$conf.low[ci$term=="sigma_E"])

  # increase just sigma_E
  t <- test_sim(sigma_O = 0.1, sigma_E = 0.3)
  t[[1]]
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  expect_lt(abs(t[["range"]]), cutoff) # just barely fails at 5%
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(0.1, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(0.1, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(0.3, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(0.3, ci$conf.low[ci$term=="sigma_E"])


  # increase both sigmas by a lot sigma_O > sigma_E
  t <- test_sim(sigma_O = 0.8, sigma_E = 0.4)
  t[[1]]
  expect_lt(abs(t[["b1"]]), fe_default*0.05)# intercept gets harder to estimate
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(0.8, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(0.8, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(0.4, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(0.4, ci$conf.low[ci$term=="sigma_E"])


  # adjust range lower
  t <- test_sim(mtrange = range_default-0.15)
  t[[1]]
  # fixed effect within 5% of true value
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  # estimate is lower than that for the default model by the amount we've changed the range from that value
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_E"])


  # adjust range higher
  t <- test_sim(mtrange = range_default*1.5)
  t[[1]]
  # fixed effect within 5% of true value
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_E"])


  ## test AR1
  t <- test_sim(rho = 0.4,
                sigma_O = 0.5, # needs larger sigma to be able to estimate it along with an AR1
                sigma_E = 0.1,
                model_type = "AR1")
  t[[1]]
  if (require("ggplot2", quietly = TRUE)) {
  ggplot2::ggplot(t[[1]]$data, aes(X, Y, colour = observed)) +
    geom_point() +
    facet_wrap(~year) +
    scale_color_gradient2()
  }
  # expect within 0.15 of true value
  expect_lt(abs(t[["rho"]]), 0.15)
  # with one seed, rho was consistently 0.1 larger than the value used in simulation
  # fixed effect within 5% of true value
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  # range within 10% of true value
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_O"])
  # expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(sigma_default, ci$conf.high[ci$term=="sigma_E"])
  # expect_gt(sigma_default, ci$conf.low[ci$term=="sigma_E"])


  ## test high AR1 values
  t <- test_sim(rho = 0.95,
                sigma_O = 0.7, # needs larger sigma to be able to estimate it along with an AR1
                sigma_E = 0.2,
                model_type = "AR1")
  if (require("ggplot2", quietly = TRUE)) {
  ggplot2::ggplot(t[[1]]$data, aes(X, Y, colour = observed)) +
    geom_point() +
    facet_wrap(~year) +
    scale_color_gradient2()
  }
  t[[1]]
  expect_lt(abs(t[["rho"]]), 0.1)
  # fixed effect within 5% of true value
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  # range within 10% of true value
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(0.7, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(0.7, ci$conf.low[ci$term=="sigma_O"])
  expect_lt(0.2, ci$conf.high[ci$term=="sigma_E"])
  expect_gt(0.2, ci$conf.low[ci$term=="sigma_E"])

  t <- test_sim(rho = 0.99,
                sigma_O = 0.7, # needs larger sigma to be able to estimate it along with an AR1
                sigma_E = 0.2,
                model_type = "RW")
  if (require("ggplot2", quietly = TRUE)) {
  ggplot2::ggplot(t[[1]]$data, aes(X, Y, colour = observed)) +
    geom_point() +
    facet_wrap(~year) +
    scale_color_gradient2()
  }
  t[[1]]
  # fixed effect within 5% of true value
  expect_lt(abs(t[["b1"]]), fe_default*0.05)
  expect_lt(abs(t[["range"]]), cutoff)
  # check if CI of estimates overlaps simulation value
  (ci <- tidy(t[[1]], effects = "ran_pars", conf.int = TRUE, silent = TRUE))
  expect_lt(0.7, ci$conf.high[ci$term=="sigma_O"])
  expect_gt(0.7, ci$conf.low[ci$term=="sigma_O"])
  # expect_lt(0.2, ci$conf.high[ci$term=="sigma_E"]) # RW underestimates sigma_E?
  expect_gt(0.2, ci$conf.low[ci$term=="sigma_E"])
})