tests/testthat/test-covlmc_predict.R

In mixvlmc: Variable Length Markov Chains with Covariates

test_that("covlmc predict returns the same value(s) for zero depth model", {
  for (k in 1:2) {
    data_set <- build_data_set(100, seed = k)
    for (engine in c("glm", "multinom")) {
      withr::local_options(mixvlmc.predictive = engine)
      model <- covlmc(data_set$x, data_set$covariate, alpha = 0.0001)
      ## make sure we are in the constant model case
      expect_equal(context_number(model), 1L)
      model_pred <- predict(model, data_set$x, data_set$covariate)
      expect_equal(
        model_pred,
        rep(model_pred[1], length(data_set$x) + 1)
      )
      model_pred <- predict(model, data_set$x, data_set$covariate, type = "probs")
      dimnames(model_pred) <- NULL
      expect_equal(
        model_pred,
        matrix(model_pred[1, ],
          nrow = length(data_set$x) + 1, ncol = ncol(model_pred),
          byrow = TRUE
        )
      )
    }
    for (engine in c("glm", "multinom")) {
      withr::local_options(mixvlmc.predictive = engine)
      data_set <- build_data_set_3_model(250, seed = k, alpha = 1e-9)
      model <- data_set$model
      ## make sure we are in the constant model case
      if (context_number(model) != 1L) {
        co <- cutoff(model)
        model <- prune(model, min(co))
      }
      expect_equal(context_number(model), 1L)
      model_pred <- predict(model, data_set$dts, data_set$cov)
      expect_equal(
        model_pred,
        rep(model_pred[1], length(data_set$dts) + 1)
      )
      model_pred <- predict(model, data_set$dts, data_set$cov, type = "probs")
      dimnames(model_pred) <- NULL
      expect_equal(
        model_pred,
        matrix(model_pred[1, ],
          nrow = length(data_set$dts) + 1, ncol = ncol(model_pred),
          byrow = TRUE
        )
      )
    }
  }
})

test_that("covlmc predict returns deterministic results", {
  for (k in 1:2) {
    for (engine in c("glm", "multinom")) {
      withr::local_options(mixvlmc.predictive = engine)
      data_set <- build_data_set_3_model(250, seed = 0, alpha = 0.1)
      model <- data_set$model
      ## make sure we are in the constant model case
      model_pred <- predict(model, data_set$dts, data_set$cov, type = "probs")
      model_pred_2 <- predict(model, data_set$dts, data_set$cov, type = "probs")
      expect_equal(
        model_pred,
        model_pred_2
      )
    }
  }
})

test_that("covlmc predict returns probabilities", {
  for (k in 1:2) {
    for (engine in c("glm", "multinom")) {
      withr::local_options(mixvlmc.predictive = engine)
      data_set <- build_data_set_3_model(250, seed = 0, alpha = 0.1)
      model <- data_set$model
      ## make sure we are in the constant model case
      model_pred <- predict(model, data_set$dts, data_set$cov, type = "probs")
      expect_probabilities(model_pred)
      data_set <- build_degenerate_elec_model()
      model <- data_set$model
      ## make sure we are in the constant model case
      model_pred <- predict(model, data_set$dts, data_set$cov, type = "probs")
      expect_probabilities(model_pred)
    }
  }
})

test_that("the semantics of final_pred is respected", {
  pc_week_15_16 <- powerconsumption[powerconsumption$week %in% c(15, 16), ]
  elec <- pc_week_15_16$active_power
  elec_dts <- cut(elec, breaks = c(0, 0.4, 2, 8), labels = c("low", "typical", "high"))
  elec_cov <- data.frame(day = (pc_week_15_16$hour >= 7 & pc_week_15_16$hour <= 18))
  for (engine in c("glm", "multinom")) {
    withr::local_options(mixvlmc.predictive = engine)

    elec_tune <- tune_covlmc(elec_dts, elec_cov, min_size = 5)
    elec_model <- as_covlmc(elec_tune)
    pred_w_final <- predict(elec_model, elec_dts[1:500], elec_cov[1:500, , drop = FALSE],
      final_pred = TRUE
    )
    pred_wo_final <- predict(elec_model, elec_dts[1:500], elec_cov[1:500, , drop = FALSE],
      final_pred = FALSE
    )
    expect_length(
      pred_w_final,
      500 + 1
    )
    expect_length(
      pred_wo_final,
      500
    )
    expect_identical(
      pred_wo_final,
      pred_w_final[-length(pred_w_final)]
    )
    probs_pred_w_final <- predict(elec_model, elec_dts[1:500], elec_cov[1:500, , drop = FALSE],
      type = "probs", final_pred = TRUE
    )
    probs_pred_wo_final <- predict(elec_model, elec_dts[1:500], elec_cov[1:500, , drop = FALSE],
      type = "probs", final_pred = FALSE
    )
    expect_equal(
      nrow(probs_pred_w_final),
      500 + 1
    )
    expect_equal(
      nrow(probs_pred_wo_final),
      500
    )
    expect_identical(
      probs_pred_wo_final,
      probs_pred_w_final[-length(pred_w_final), , drop = FALSE]
    )
  }
})