tests/testthat/test-covlmc_trim.R

In mixvlmc: Variable Length Markov Chains with Covariates

test_that("trimming removes only what it should remove", {
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    for (k in 2:3) {
      pc <- powerconsumption[powerconsumption$week %in% 5:7, ]
      probs <- (1:k) / k
      dts <- cut(pc$active_power, breaks = c(0, quantile(pc$active_power, probs = probs)))
      dts_cov <- data.frame(day_night = (pc$hour >= 7 & pc$hour <= 17))
      m_cov <- covlmc(dts, dts_cov, min_size = 10, keep_data = TRUE)
      t_m_cov_model <- trim(m_cov, keep_model = TRUE)
      t_m_cov <- trim(m_cov)
      ## size reduction
      expect_true(object.size(t_m_cov_model) < object.size(m_cov))
      expect_true(object.size(t_m_cov) < object.size(t_m_cov_model))
      ## identical contexts
      expect_identical(
        contexts(m_cov, type = "data.frame", hsize = TRUE, model = "coef", frequency = "detailed", metrics = TRUE, merging = TRUE),
        contexts(t_m_cov_model, type = "data.frame", hsize = TRUE, model = "coef", frequency = "detailed", metrics = TRUE, merging = TRUE)
      )
      expect_identical(
        contexts(m_cov, type = "data.frame", hsize = TRUE, model = "coef", frequency = "detailed", metrics = TRUE, merging = TRUE),
        contexts(t_m_cov, type = "data.frame", hsize = TRUE, model = "coef", frequency = "detailed", metrics = TRUE, merging = TRUE)
      )
      ## still usable with keep_mode==TRUE
      expect_equal(
        loglikelihood(m_cov, newdata = dts, newcov = dts_cov),
        loglikelihood(t_m_cov_model, newdata = dts, newcov = dts_cov)
      )
      expect_no_error(contexts(t_m_cov_model, type = "data.frame", hsize = TRUE, model = "full"))
      expect_equal(
        simulate(m_cov, nsim = 50, seed = 0, dts_cov),
        simulate(t_m_cov_model, nsim = 50, seed = 0, dts_cov)
      )
      ## errors
      expect_error(
        contexts(t_m_cov, type = "data.frame", hsize = TRUE, model = "full"),
        "Full model extraction is not supported by fully trimmed covlmc"
      )
      expect_error(
        loglikelihood(t_m_cov, newdata = dts, newcov = dts_cov),
        "loglikelihood calculation for new data is not supported by fully trimmed covlmc"
      )
      expect_error(
        simulate(t_m_cov, nsim = 50, seed = 0, dts_cov),
        "simulate is not supported by fully trimmed covlmc"
      )
      expect_error(
        metrics(t_m_cov),
        "metrics is not supported by trimmed covlmc"
      )
      expect_error(
        metrics(t_m_cov_model),
        "metrics is not supported by trimmed covlmc"
      )
      expect_error(
        prune(t_m_cov),
        "covlmc must be called with keep_data=TRUE to enable post pruning"
      )
      expect_error(
        prune(t_m_cov_model),
        "covlmc must be called with keep_data=TRUE to enable post pruning"
      )
    }
  }
})

test_that("trimmed model can be drawn", {
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)
    pc <- powerconsumption[powerconsumption$week %in% 5:7, ]
    for (k in 2:3) {
      probs <- (1:k) / k
      dts <- cut(pc$active_power, breaks = c(0, quantile(pc$active_power, probs = probs)))
      dts_cov <- data.frame(day_night = (pc$hour >= 7 & pc$hour <= 17))
      m_cov <- covlmc(dts, dts_cov, min_size = 10, keep_data = TRUE)
      t_m_cov_model <- trim(m_cov, keep_model = TRUE)
      t_m_cov <- trim(m_cov)
      expect_snapshot(draw(t_m_cov_model, model = "coef", time_sep = " | ", with_state = TRUE, digits = 2))
      expect_snapshot(draw(t_m_cov, model = "coef", time_sep = " | ", with_state = TRUE, digits = 2))
      expect_snapshot(draw(t_m_cov_model, model = "full", time_sep = " | ", with_state = TRUE, digits = 2))
      expect_snapshot(draw(t_m_cov, model = "full", time_sep = " | ", with_state = TRUE, digits = 2))
    }
  }
})