tests/testthat/test-random.R

In santikka/dynamite: Bayesian Modeling and Causal Inference for Multivariate Longitudinal Data

#' @srrstats {G5.10} Extended tests can be switched on via setting the
#'   environment variable DYNAMITE_EXTENDED_TESTS to "true".

run_extended_tests <- identical(Sys.getenv("DYNAMITE_EXTENDED_TESTS"), "true")

data.table::setDTthreads(1) # For CRAN

test_that("multiple random effects work in fit and predict", {
  skip_if_not(run_extended_tests)

  set.seed(1)
  n <- 40
  k <- 10
  x <- rnorm(n * k)
  u1 <- rep(rnorm(k, sd = 0.2), each = n)
  u2 <- 0.5 * u1 + rep(rnorm(k, sd = 0.1), each = n)
  u3 <- 0.2 * u1 + rep(rnorm(k, sd = 0.3), each = n)
  y1 <- rbinom(n * k, size = 20, prob = plogis(x + u1 + u2 * x))
  y2 <- rnorm(n * k, u3 + 2 * x)
  d <- data.frame(
    year = 1:n, person = rep(1:k, each = n),
    y1 = y1, y2 = y2, x = x, tr = 20
  )

  expect_error(
    fit <- dynamite(
      obs(y1 ~ x + trials(tr) + random(~x), family = "binomial") +
        obs(y2 ~ x + random(~1), family = "gaussian") +
        random_spec(),
      data = d, time = "year", group = "person",
      chains = 1, iter = 2000, refresh = 0
    ),
    NA
  )

  expect_error(
    sumr <- summary(fit, type = "sigma_nu"),
    NA
  )
  expect_equal(sumr$mean, c(0.2338, 0.1331, 0.3339), tolerance = 0.2)

  expect_error(
    sumr <- summary(fit, type = "corr_nu"),
    NA
  )
  expect_equal(sumr$mean, c(0.336, -0.0522, -0.0712), tolerance = 0.2)

  expect_error(
    predict(fit, n_draws = 5),
    NA
  )

  newdata <- rbind(
    d[(n + 1):nrow(d), ], # remove one person and add two
    data.frame(
      y1 = c(4, rep(NA, n - 1), 4, rep(NA, n - 1)),
      y2 = c(0, rep(NA, n - 1), 0.5, rep(NA, n - 1)),
      x = rnorm(2 * n),
      person = rep(c(226L, 500L), each = n),
      year = seq.int(1, n),
      tr = rep(c(10, 25), each = n)
    )
  )
  expect_error(
    predict(
      fit,
      newdata = newdata,
      type = "response",
      n_draws = 5,
      new_levels = "bootstrap"
    ),
    NA
  )
  expect_error(
    predict(
      fit,
      newdata = newdata,
      type = "response",
      n_draws = 5,
      new_levels = "gaussian"
    ),
    NA
  )
  expect_error(
    predict(
      fit,
      newdata = newdata,
      type = "response",
      n_draws = 2,
      new_levels = "original"
    ),
    NA
  )
})

test_that("centered and noncentered parameterization for random effects work", {
  skip_if_not(run_extended_tests)

  set.seed(1)
  n <- 40
  k <- 10
  x <- rnorm(n * k)
  u1 <- rep(rnorm(k, sd = 0.2), each = n)
  u2 <- rep(rnorm(k, sd = 0.1), each = n)
  mu <- exp(4 + x + u1 + u2 * x)
  phi <- 50
  y <- rnbinom(n * k, mu = mu, size = phi)
  d <- data.frame(year = 1:n, person = rep(1:k, each = n), y = y, x = x)

  fit_centered <- dynamite(
    obs(y ~ x + random(~ 1 + x), family = "negbin") +
      random_spec(noncentered = FALSE, correlated = TRUE),
    data = d, time = "year", group = "person",
    chains = 2, iter = 4000, refresh = 0, seed = 1
  )
  fit_noncentered <- dynamite(
    obs(y ~ x + random(~ 1 + x), family = "negbin") +
      random_spec(noncentered = TRUE, correlated = TRUE),
    data = d, time = "year", group = "person",
    chains = 2, iter = 4000, refresh = 0, seed = 1
  )

  expect_equal(
    summary(
      fit_centered,
      types = c("alpha", "beta", "corr_nu", "sigma_nu", "nu")
    )$mean,
    summary(
      fit_noncentered,
      types = c("alpha", "beta", "corr_nu", "sigma_nu", "nu")
    )$mean,
    tolerance = 0.1
  )
  expect_equal(
    summary(fit_centered, parameter = "phi_y")$mean,
    summary(fit_noncentered, parameter = "phi_y")$mean,
    tolerance = 0.2
  )

  fit_centered_nocorr <- dynamite(
    obs(y ~ x + random(~ 1 + x), family = "negbin") +
      random_spec(noncentered = FALSE, correlated = FALSE),
    data = d, time = "year", group = "person",
    chains = 2, iter = 4000, refresh = 0, seed = 1
  )
  fit_noncentered_nocorr <- dynamite(
    obs(y ~ x + random(~ 1 + x), family = "negbin") +
      random_spec(noncentered = TRUE, correlated = FALSE),
    data = d, time = "year", group = "person",
    chains = 2, iter = 4000, refresh = 0, seed = 1
  )

  expect_equal(
    summary(
      fit_centered_nocorr,
      types = c("alpha", "beta", "sigma_nu", "nu")
    )$mean,
    summary(
      fit_noncentered_nocorr,
      types = c("alpha", "beta", "sigma_nu", "nu")
    )$mean,
    tolerance = 0.1
  )
  expect_equal(
    summary(
      fit_noncentered,
      types = c("alpha", "beta", "sigma_nu", "nu")
    )$mean,
    summary(
      fit_noncentered_nocorr,
      types = c("alpha", "beta", "sigma_nu", "nu")
    )$mean,
    tolerance = 0.1
  )
})

test_that("random effects for categorical distribution work", {
  skip_if_not(run_extended_tests)

  set.seed(1)
  f <- obs(x ~  lag(x) + lag(y) + random(~1 + z), family = "categorical") +
    obs(y ~ -1 + lag(x) + lag(y) + random(~z), family = "categorical")
  fit <- try(
    # Suppress, as this produces divergences
    suppressWarnings(
      dynamite(
        dformula = f,
        data = categorical_example,
        time = "time",
        group = "id",
        chains = 1,
        iter = 2000,
        refresh = 0
      )
    ),
    silent = TRUE
  )
  expect_false(inherits(fit, "try-error"))
  expect_error(
    pred <- predict(fit, n_draws = 5),
    NA
  )
})

test_that("random effects for multinomial distribution work", {
  skip_if_not(run_extended_tests)

  set.seed(1)
  d <- as.data.frame(t(rmultinom(100, 150, prob = c(0.15, 0.55, 0.3))))
  names(d) <- c("y1", "y2", "y3")
  d$t <- rep(1:20, each = 5)
  d$id <- rep(1:5, 20)
  d$x <- rnorm(100)
  d$n <- d$y1 + d$y2 + d$y3

  fit <- try(
    # Suppress, as this produces divergences
    suppressWarnings(
      dynamite(
        obs(c(y1, y2, y3) ~ 1 + random(~ -1 + x) + trials(n), "multinomial"),
        data = d,
        time = "t",
        group = "id",
        chains = 1,
        iter = 2000,
        refresh = 0
      )
    ),
    silent = TRUE
  )
  expect_false(inherits(fit, "try-error"))
  expect_error(
    pred <- predict(fit, n_draws = 5),
    NA
  )
})

test_that("random effects for multivariate gaussian distribution work", {
  skip_if_not(run_extended_tests)

  set.seed(1)
  N <- 5
  T_ <- 20
  S <- crossprod(matrix(rnorm(4), 2, 2))
  L <- t(chol(S))
  y1 <- matrix(0, N, T_)
  y2 <- matrix(0, N, T_)
  x <- matrix(0, N, T_)
  for (t in 2:T_) {
    for (i in 1:N){
      mu <- c(0.7 * y1[i, t - 1], 0.4 * y2[i, t - 1] - 0.2 * y1[i, t - 1])
      y <- mu + L %*% rnorm(2L)
      y1[i, t] <- y[1L]
      y2[i, t] <- y[2L]
      x[i, t] <- rnorm(1, c(0.5 * y1[i, t - 1]), 0.5)
    }
  }
  d <- data.frame(
    y1 = c(y1),
    y2 = c(y2),
    x = c(x),
    t = rep(1:T_, each = N),
    id = 1:N
  )
  fit <- try(
    # Suppress, as this produces divergences
    suppressWarnings(
      dynamite(
        dformula =
          obs(c(y1, y2) ~ -1 + random(~ 1) + varying(~ x) | x, "mvgaussian") +
          splines(df = 10) ,
        data = d,
        time = "t",
        group = "id",
        chains = 1,
        iter = 2000,
        refresh = 0
      )
    ),
    silent = TRUE
  )
  expect_false(inherits(fit, "try-error"))
  expect_error(
    pred <- predict(fit, ndraws = 5),
    NA
  )
})