tests/testthat/test-mix.R

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

test_that("Gamma, NB2, and lognormal mixtures fit and recover mixing proportion", {
  skip_on_cran()
  d <- pcod[pcod$year == 2017 & pcod$density > 0, ]
  spde <- make_mesh(d, c("X", "Y"), cutoff = 10)
  m <- sdmTMB(
    data = d, formula = density ~ 1,
    mesh = spde, family = gamma_mix(link = "log"),
    spatial = "off",
    control = sdmTMBcontrol(newton_loops = 1)
  )
  expect_true(all(!is.na(summary(m$sd_report)[, "Std. Error"])))
  # expect_length(residuals(m), nrow(d))

  # test non-spatial model
  set.seed(123)
  d <- pcod[pcod$density > 0, ]
  d$cluster <- sample(1:2, size = nrow(d), replace = TRUE, prob = c(0.9, 0.1))
  d$y <- rnorm(n = nrow(d), c(1, 4)[d$cluster], sd = 0.1)
  m <- sdmTMB(
    data = d, formula = y ~ 1,
    family = gamma_mix(),
    spatial = "off"
  )
  expect_equal(m$model$par[["logit_p_mix"]], stats::qlogis(0.1), tolerance = 0.1)
  expect_equal(exp(m$model$par[["log_ratio_mix"]]), 3.0, tolerance = 0.01)

  p <- predict(m, newdata = m$data)
  expect_equal(mean(p$est), log(mean(d$y)), tolerance = 0.001)

  # lognormal
  m <- sdmTMB(
    data = d, formula = y ~ 1,
    family = lognormal_mix(),
    spatial = "off"
  )
  expect_equal(m$model$par[["logit_p_mix"]], stats::qlogis(0.1), tolerance = 0.1)
  expect_equal(exp(m$model$par[["log_ratio_mix"]]), 3.0, tolerance = 0.01)

  # NB2
  set.seed(123)
  mix_ratio <- 10
  y_small <- rnbinom(5000, size = 2, mu = 4)
  y_large <- rnbinom(5000, size = 2, mu = 4 * mix_ratio)
  cluster <- sample(1:2, size = length(y_small), replace = TRUE, prob = c(0.9, 0.1))
  y <- ifelse(cluster == 1, y_small, y_large)
  d <- data.frame(y = y)
  m <- sdmTMB(
    data = d, formula = y ~ 1,
    family = nbinom2_mix(),
    spatial = "off"
  )
  expect_equal(m$model$par[["logit_p_mix"]], stats::qlogis(0.1), tolerance = 0.1)
  expect_equal(1 + exp(m$model$par[["log_ratio_mix"]]), mix_ratio, tolerance = 0.1)

  p <- predict(m, newdata = m$data)
  expect_equal(mean(p$est), log(mean(d$y)), tolerance = 0.001)
})

test_that("Test that residuals and prediction functions work with mixture models", {
  skip_on_cran()
  d <- pcod[pcod$year == 2017 & pcod$density > 0, ]
  m <- sdmTMB(
    data = d, formula = density ~ 1,
    family = lognormal_mix(link = "log"),
    spatial = "off"
  )
  expect_true(all(!is.na(summary(m$sd_report)[, "Std. Error"])))
  # expect_length(residuals(m), nrow(d))
  expect_length(predict(m)[["est"]], nrow(d))
  p <- predict(m, newdata = m$data)
  expect_equal(mean(p$est), log(mean(d$density)), tolerance = 0.01)
})

test_that("Test that delta Gamma mixture fits", {
  skip_on_cran()
  d <- pcod
  m <- sdmTMB(
    data = d, formula = density ~ 1,
    family = delta_gamma_mix(),
    spatial = "off"
  )
  p <- predict(m, newdata = m$data, type = "response")
  expect_equal(mean(p$est), mean(d$density), tolerance = 0.01)
  # expect_length(residuals(m), nrow(d))
  # set.seed(123)
  # d$test_gamma <- stats::rgamma(nrow(d), shape = 0.5, scale = 1 / 0.5)
  # m <- sdmTMB(data = d, formula = test_gamma ~ 1,
  #             mesh = spde, family = gamma_mix(link = "inverse"), spatiotemporal = "off",
  #             control = sdmTMBcontrol(newton_loops = 1))
})

test_that("Test that delta lognormal mixture fits", {
  skip_on_cran()

  set.seed(1)
  y1 <- stats::rlnorm(1000, 0, 0.5)
  y2 <- stats::rlnorm(1000, 1, 0.5)
  d <- data.frame(y = c(y1, y2))

  m <- sdmTMB(
    data = d,
    formula = y ~ 1,
    family = delta_lognormal_mix(),
    spatial = "off"
  )
  p <- predict(m, newdata = m$data, type = "response")
  expect_equal(mean(p$est), mean(d$y), tolerance = 0.01)
  # expect_length(residuals(m, model = 2), nrow(d))
})

test_that("Test that simulation functions work with mixture models", {
  skip_on_cran()

  set.seed(123)
  d <- pcod[pcod$density > 0, ]
  d$cluster <- sample(1:2, size = nrow(d), replace = T, prob = c(0.7, 0.3))
  phi <- 0.8
  d$y <- stats::rgamma(nrow(d), shape = phi, scale = c(2, 10)[d$cluster] / phi)

  m_gamma <- sdmTMB(
    data = d, formula = density ~ 1,
    family = gamma_mix(link = "log"),
    spatial = "off",
    control = sdmTMBcontrol(newton_loops = 1)
  )

  set.seed(123)
  d$cluster <- sample(1:2, size = nrow(d), replace = T, prob = c(0.7, 0.3))
  d$y <- stats::rlnorm(nrow(d), meanlog = log(c(2, 10))[d$cluster], sdlog = 0.5)

  m_logn <- sdmTMB(
    data = d, formula = y ~ 1,
    family = lognormal_mix(link = "log"),
    spatial = "off",
    control = sdmTMBcontrol(newton_loops = 1)
  )
  expect_length(simulate(m_gamma), nrow(d))
  expect_length(simulate(m_logn), nrow(d))
})