tests/testthat/test-covlmc_simulate.R

In mixvlmc: Variable Length Markov Chains with Covariates

test_that("covlmc simulation generates a consistent sample", {
  data_set <- build_data_set(500, seed = 0)
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    model <- covlmc(data_set$x, data_set$covariate, alpha = 0.2)
    xs <- simulate(model, 250, covariate = data_set$covariate[1:250, , drop = FALSE], seed = 1)
    expect_equal(length(xs), 250)
    expect_identical(sort(unique(xs)), states(model))
  }
  withr::local_seed(0)
  x <- sample(c("A", "B", "C"), 500, replace = TRUE)
  y <- ifelse(runif(length(x)) > 0.5, c(x[-1], sample(c("A", "B", "C"), 1)), c(x[-c(1, 2)], sample(c("A", "B", "C"), 2, replace = TRUE)))
  y <- as.factor(ifelse(runif(length(x)) > 0.2, y, sample(c("A", "B", "C"), 500, replace = TRUE)))
  df_y <- data.frame(y = y, z = runif(length(y)))
  new_cov <- df_y[sample(1:nrow(df_y), 250, replace = TRUE), ]
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    model <- covlmc(x, df_y, alpha = 1e-8)
    xs <- simulate(model, 250, covariate = new_cov, seed = 1)
    my_seed <- 1
    attr(my_seed, "kind") <- as.list(RNGkind())
    expect_equal(length(xs), 250)
    expect_identical(attr(xs, "seed"), my_seed)
    expect_identical(sort(unique(xs)), states(model))
  }
})

test_that("covlmc simulation generates always the same sample with the same seed", {
  for (k in 1:4) {
    data_set <- build_data_set(250, seed = k)
    for (engine in c("glm", "multinom")) {
      withr::local_options(mixvlmc.predictive = engine)
      model <- covlmc(data_set$x, data_set$covariate, alpha = 0.1)
      xs <- simulate(model, 250, seed = 2 * k + 1, covariate = data_set$covariate[1:250, , drop = FALSE])
      xs2 <- simulate(model, 250, seed = 2 * k + 1, covariate = data_set$covariate[1:250, , drop = FALSE])
      expect_identical(xs2, xs)
    }
  }
})

test_that("covlmc simulates uses correctly the initial values", {
  data_set <- build_data_set(500, seed = 0)
  model <- covlmc(data_set$x, data_set$covariate, alpha = 0.2)
  init <- sample(states(model), 10, replace = TRUE)
  xs <- simulate(model, 100, covariate = data_set$covariate[1:250, , drop = FALSE], init = init)
  expect_identical(xs[1:length(init)], init)
  withr::local_seed(0)
  x <- sample(c("A", "B", "C"), 500, replace = TRUE)
  y <- ifelse(runif(length(x)) > 0.5, c(x[-1], sample(c("A", "B", "C"), 1)), c(x[-c(1, 2)], sample(c("A", "B", "C"), 2, replace = TRUE)))
  y <- as.factor(ifelse(runif(length(x)) > 0.2, y, sample(c("A", "B", "C"), 500, replace = TRUE)))
  df_y <- data.frame(y = y, z = runif(length(y)))
  new_cov <- df_y[sample(1:nrow(df_y), 250, replace = TRUE), ]
  model <- covlmc(x, df_y, alpha = 1e-8)
  init <- sample(states(model), 15, replace = TRUE)
  rng <- .Random.seed
  xs <- simulate(model, 250, covariate = new_cov, init = init)
  expect_identical(xs[1:length(init)], init)
  expect_identical(attr(xs, "seed"), rng)
})

test_that("covlmc simulate detects unadapted init values", {
  data_set <- build_data_set(500, seed = 0)
  model <- covlmc(data_set$x, data_set$covariate, alpha = 0.2)
  expect_error(simulate(model, 100, covariate = data_set$covariate[1:250, , drop = FALSE], init = c(0L, 1L)))
  withr::local_seed(0)
  x <- sample(c("A", "B", "C"), 500, replace = TRUE)
  y <- ifelse(runif(length(x)) > 0.5, c(x[-1], sample(c("A", "B", "C"), 1)), c(x[-c(1, 2)], sample(c("A", "B", "C"), 2, replace = TRUE)))
  y <- as.factor(ifelse(runif(length(x)) > 0.2, y, sample(c("A", "B", "C"), 500, replace = TRUE)))
  df_y <- data.frame(y = y, z = runif(length(y)))
  new_cov <- df_y[sample(1:nrow(df_y), 250, replace = TRUE), ]
  model <- covlmc(x, df_y, alpha = 1e-8)
  expect_error(simulate(model, 250, covariate = new_cov, init = c("A", "D")))
  init <- sample(states(model), 15, replace = TRUE)
  expect_error(simulate(model, 10, covariate = new_cov, init = init))
})

test_that("covlmc simulate handles missing factors in subsets", {
  withr::local_seed(0)
  x <- sample(c(0, 1), 200, replace = TRUE)
  xl1 <- forward_match_all_ctx_counts(x, 2)
  xl2_0 <- forward_match_all_ctx_counts(x, 2, 1, xl1$positions[[1]])
  xl2_1 <- forward_match_all_ctx_counts(x, 2, 1, xl1$positions[[2]])
  y <- rep(1, length(x))
  y[xl2_0$positions[[1]] + 1] <- sample(2:4, length(xl2_0$positions[[1]]), replace = TRUE)
  y[xl2_0$positions[[2]] + 1] <- sample(c(1, 3:4), length(xl2_0$positions[[2]]), replace = TRUE)
  y[xl2_1$positions[[1]] + 1] <- sample(c(1:2, 4), length(xl2_1$positions[[1]]), replace = TRUE)
  y[xl2_1$positions[[2]] + 1] <- sample(1:3, length(xl2_1$positions[[2]]), replace = TRUE)
  y <- as.factor(y)
  z <- runif(length(x)) + c(x[-1], 0) / 4
  dts_cov <- data.frame(y = y, z = z)
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    m_cov <- covlmc(x = x, covariate = dts_cov, min_size = 5, alpha = 0.5)
    expect_error(simulate(m_cov, 100, seed = 0, covariate = dts_cov), regexp = NA)
  }
})

test_that("covlmc simulate detects new levels in factors", {
  data <- build_data_set_2(0)
  model <- covlmc(data$x, data$covariate, min_size = 5, alpha = 0.1)
  new_cov <- data$covariate
  new_cov$y <- as.integer(new_cov$y)
  new_cov$y[1] <- 5
  expect_error(simulate(model, 100, covariate = new_cov), regexp = "Factor y has new level 5")
  new_cov$y[2] <- 6
  expect_error(simulate(model, 100, covariate = new_cov), regexp = "Factor y has new levels 5, 6")
})

test_that("covlmc simulate works correctly with degenerate models", {
  d_model <- build_degenerate_elec_model(TRUE)
  expect_no_error(result <- simulate(d_model$model,
    nsim = nrow(d_model$new_cov),
    covariate = d_model$new_cov, seed = 0
  ))
  expect_equal(length(result), nrow(d_model$new_cov))
})