tests/testthat/test-covlmc_draw.R

In mixvlmc: Variable Length Markov Chains with Covariates

test_that("draw obeys its contract (with vgam)", {
  withr::local_seed(0)
  dts <- sample(c("A", "B", "C"), 1000, replace = TRUE)
  y <- ifelse(runif(length(dts)) > 0.5, c(dts[-1], sample(c("A", "B", "C"), 1)), c(dts[-c(1, 2)], sample(c("A", "B", "C"), 2, replace = TRUE)))
  y <- as.factor(ifelse(runif(length(dts)) > 0.2, y, sample(c("A", "B", "C"), length(dts), replace = TRUE)))
  df_y <- data.frame(y = y)
  model <- covlmc(dts, df_y, alpha = 0.01, min_size = 1.5)
  expect_snapshot_output(draw(model, model = NULL, p_value = FALSE))
  expect_snapshot_output(draw(prune(model, 0.0001)))
  expect_snapshot_output(draw(prune(model, 0.0001), time_sep = " | "))
  expect_snapshot_output(draw(prune(model, 0.0001), model = "full", time_sep = " | "))
  expect_snapshot_output(draw(prune(model, 0.0001), model = "full", time_sep = " | ", with_state = TRUE))
  expect_snapshot_output(draw(prune(model, 0.0001), model = "coef", time_sep = " | ", with_state = TRUE))
  ## the following snapshots depend on blas version
  ## skip_on_ci()
  ##  expect_snapshot_output(draw(model))
  ##  expect_snapshot_output(draw(model, time_sep = " | "))
  ##  expect_snapshot_output(draw(model, digits = 3))
  ##  expect_snapshot_output(draw(model, model = NULL, digits = 2))
  ##  expect_snapshot_output(draw(model, p_value = FALSE, digits = 1))
  ##  expect_snapshot_output(draw(model, model = "full", time_sep = " ~ ", digits = 1))
  ##  expect_snapshot_output(draw(model, model = "full", time_sep = " ~ ", digits = 5, with_state = TRUE))
  ##  expect_snapshot_output(draw(model, model = "coef", time_sep = " ~ ", digits = 5, with_state = TRUE))
})

test_that("draw obeys its contract (with nnet)", {
  withr::local_seed(0)
  withr::local_options(mixvlmc.predictive = "multinom")
  dts <- sample(c("A", "B", "C"), 1000, replace = TRUE)
  y <- ifelse(runif(length(dts)) > 0.5, c(dts[-1], sample(c("A", "B", "C"), 1)), c(dts[-c(1, 2)], sample(c("A", "B", "C"), 2, replace = TRUE)))
  y <- as.factor(ifelse(runif(length(dts)) > 0.2, y, sample(c("A", "B", "C"), length(dts), replace = TRUE)))
  df_y <- data.frame(y = y)
  model <- covlmc(dts, df_y, alpha = 0.01, min_size = 1.5)
  expect_snapshot_output(draw(model))
  expect_snapshot_output(draw(model, time_sep = " | "))
  expect_snapshot_output(draw(model, digits = 3))
  expect_snapshot_output(draw(model, model = NULL, digits = 2))
  expect_snapshot_output(draw(model, p_value = FALSE, digits = 1))
  expect_snapshot_output(draw(model, model = "full", time_sep = " ^ ", digits = 1))
  expect_snapshot_output(draw(model, model = "full", time_sep = " ^ ", digits = 3, with_state = TRUE))
  expect_snapshot_output(draw(model, model = "coef", time_sep = " ^ ", digits = 3, with_state = TRUE))
})

test_that("draw handles cases when levels have been dropped", {
  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)
  m_cov <- covlmc(x = x, covariate = dts_cov, min_size = 3, alpha = 0.5)
  expect_snapshot_output(draw(m_cov, model = "full", time_sep = " | ", digits = 1))
  expect_snapshot_output(draw(m_cov, model = "full", time_sep = " | ", digits = 2, with_state = TRUE))
})

test_that("draw handles cases when multinom is used for two states time series", {
  withr::local_seed(0)
  withr::local_options(mixvlmc.predictive = "multinom")
  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)
  m_cov <- covlmc(x = x, covariate = dts_cov, min_size = 3, alpha = 0.5)
  expect_snapshot_output(draw(m_cov, model = "full", time_sep = " | ", digits = 1))
  expect_snapshot_output(draw(m_cov, model = "full", time_sep = " | ", digits = 1, with_state = TRUE))
})

test_that("draw handles degenerate cases", {
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    pc <- powerconsumption[powerconsumption$week %in% 5:7, ]
    dts <- cut(pc$active_power, breaks = c(0, quantile(pc$active_power, probs = c(0.5, 1))))
    dts_cov <- data.frame(day_night = (pc$hour >= 7 & pc$hour <= 17))
    m_cov <- covlmc(dts, dts_cov, min_size = 10, keep_data = TRUE)
    expect_snapshot_output(draw(m_cov, model = "coef", time_sep = " | ", with_state = TRUE, digits = 2))
    expect_snapshot_output(draw(m_cov, model = "full", time_sep = " | ", with_state = TRUE, digits = 2))
  }
})