tests/testthat/test-hybridModel.R

In forecastHybrid: Convenient Functions for Ensemble Time Series Forecasts

# Unit tests on the hybridModel function
context("Testing input for hybridModel()")
test_that("Testing invalid inputs", {
  # Invalid arguments for models
  expect_error(hybridModel(y = 1:10, models = "jten"))
  expect_error(hybridModel(y = 1:10, models = "ae32"))
  expect_error(hybridModel(y = 1:10, models = "32"))
  expect_error(hybridModel(y = 1:10, models = ""))
  # models must be characters
  expect_error(hybridModel(y = 1:10, models = 5))
  expect_error(hybridModel(y = matrix(1:10, nrow = 5, ncol = 2),
                           models = 5))
  # Test for invalid mismatch length of y and xreg in a.args/s.args later?
  badxreg <- rnorm(length(wineind) - 1)
  expect_warning(expect_error(hybridModel(y = wineind, a.args = list(xreg = badxreg))))
  # More invalid inputs
  expect_error(hybridModel(y = "hello world"))
  # must provide input series
  expect_error(hybridModel())
  # input series must have data
  expect_error(hybridModel(y = numeric()))
  # input series must be numeric
  expect_error(hybridModel(y = "aten"))
  # models must be one of a, e, f, t, n, s, z
  expect_error(hybridModel(y = wineind, models = "abcderfghijk"))
  # ensemble must have at least two models
  expect_error(hybridModel(wineind, models = "a"))
  # num.core must be positive
  expect_error(hybridModel(wineind, num.cores = -1L))
  # num.cores must be an integer
  expect_error(hybridModel(wineind, num.cores = 3.3))
  # num.cores must be numeric
  expect_error(hybridModel(wineind, num.cores = "a"))
  # models must not be empty string
  expect_error(hybridModel(wineind, models = ""))
  # parallel should be a boolean
  expect_error(hybridModel(wineind, parallel = "a"))
})

test_that("Testing for warnings", {
  # hybridModel creates a warning when an arg list for an unused model is passed
  expect_warning(hybridModel(wineind, models = "fs", a.args = list()))
  expect_warning(hybridModel(wineind, models = "fs", e.args = list()))
  expect_warning(hybridModel(wineind, models = "fs", n.args = list()))
  expect_warning(hybridModel(wineind, models = "fn", s.args = list()))
  expect_warning(hybridModel(wineind, models = "fs", t.args = list()))
  # thetam() requires at least one seasonal period of data
  expect_warning(hybridModel(ts(rnorm(4), f = 7), models = "aef"))
  # ts is too short: nnetar() and stlm() with 2 * frequency(y) >= length(y)
  inputSeries <- ts(rnorm(8), f = 4)
  expect_warning(hybridModel(inputSeries, models = "aesn"))
  # ts is too short: stlm() with 2 * frequency(y) >= length(y)
  inputSeries <- ts(rnorm(7), f = 4)
  expect_warning(hybridModel(inputSeries, models = "efs"))
  # ets with frequency(y) > 24
  inputSeries <- ts(rnorm(75), f = 25)
  expect_warning(hybridModel(inputSeries, models = "ens"))
  # weights = "cv.weights" with errorMethod = "MASE" is not yet implemented
  expect_warning(hybridModel(wineind, models = "fs", weights = "cv.errors",
                             errorMethod = "MASE"))
  # weights = "insample.errors" when there is a perfect fit
  expect_warning(hybridModel(ts(1:20, f = 2), weight = "insample.errors"))
})

test_that("Testing valid inputs", {
  set.seed(54321)
  expect_error(hybridModel(wineind, models = "an", f.args = list()))
  expect_error(hybridModel(y = rnorm(10), models = "ae",
                           a.args = list(xreg = matrix(runif(10), nrow = 10))), NA)
  expect_warning(hybridModel(y = rnorm(10), models = "en",
                             a.args = list(lambda = 0.5)))
  inputSeries <- ts(rnorm(9), f = 4)
  expect_warning(hybridModel(inputSeries, models = "aensft",
                             weights = "insample.errors"))
  # soft deprecated insample.errors
  expect_warning(hybridModel(wineind, models = "fs",
                             weights = "insample.errors"))
  expect_error(hybridModel(inputSeries, models = "ae",
                           e.args = list(lambda = 0.5)), NA)
  # test parallel
  inputSeries <- ts(rnorm(8), f = 2)
  expect_warning(hybridModel(inputSeries, models = "fs", parallel = TRUE), NA)
  expect_warning(hybridModel(inputSeries, models = "fs", parallel = TRUE,
                             num.cores = 2), NA)
})

test_that("Testing long data", {
  set.seed(42)
  dat <- ts(rnorm(52 * 3), f = 52)
  expect_warning(hm <- hybridModel(y = dat, models = "fs"), NA) # nolint: implicit_assignment_linter
  expect_length(forecast(hm)$mean, 52 * 2)
  # Test for messy function call
  hm <- hybridModel(wineind)
  # Disable these for now because fails on r-devel
  # Less than orignal, messy function call
  # works on ARM, not AMD64 expect_true(format(object.size(hm)) <= "6035456 bytes")
  # No worse than improved function call
  # previously tested withexpect_true(format(object.size(hm)) <= "322352 bytes")
})

test_that("Testing model matching", {
  set.seed(123456)
  expect_error(hybridModel(y = rnorm(20), models = "AAAAE"), NA)
  expect_error(hybridModel(y = rnorm(20), models = "AtTaaa"), NA)
  expect_error(hybridModel(y = rnorm(20), models = "nNeTEEEeA"), NA)
})

context("Testing cv.errors")
test_that("Testing hybridModel(weights = \"cv.errors\")", {
  set.seed(33)
  inputSeries <- ts(rnorm(12), f = 2)
  expect_error(cvMod <- hybridModel(inputSeries, weights = "cv.errors", # nolint: implicit_assignment_linter
                                    windowSize = 8, cvHorizon = 2), NA)
  expect_length(cvMod$weights, length(unique(cvMod$weights)))
})

test_that("Testing the hybridModel object", {
  modelComparison <- list()
  for (parallel in c(FALSE, TRUE)) {
    set.seed(4)
    len <- 20
    freq <- 2
    tol <- 10^-8
    testSeries <- ts(rnorm(len), f = freq)
    cols <- c("a", "b", "c")
    xreg <- matrix(rnorm(len * length(cols)), nrow = len)
    colnames(xreg) <- cols
    # Ignore nnetar for now since it isn't reproducible
    # TODO: add nnetar to xreg tests
    models <- "aefstz"
    hm <- hybridModel(testSeries, models = models,
                      a.args = list(xreg = xreg), lambda = 0.2,
                      parallel = parallel)
    for (obj in hm) {
      expect_true(all(class(obj) != "NULL"))
      expect_false(is.null(obj))
    }
    # Ensure numeric values
    expect_true(is.numeric(hm$fitted)) # nolint: expect_type_linter
    expect_true(is.numeric(hm$residuals)) # nolint: expect_type_linter
    expect_true(is.numeric(hm$x)) # nolint: expect_type_linter
    expect_length(hm$fitted, length(testSeries))
    expect_length(hm$residuals, length(testSeries))
    expect_length(hm$x, length(testSeries))
    expect_true(all(hm$weights >= 0))
    # Weights should sum to 1 but allow tolerance
    expect_lt(sum(hm$weights) - 1, tol)
    expect_length(hm$weights, nchar(models))
    expect_identical(hm$frequency, freq)
    # Ensure xreg is correct
    expect_true(all(hm$auto.arima$xreg == xreg))
    expect_true(hm$xreg$auto.arima)
    expect_false(hm$xreg$stlm)
    # Ensure other fields are correct
    expect_length(hm$models, nchar(models))
    expect_true(all(names(hm$weights) == hm$models))
    # Ensure the models are of the expected classes
    expect_true(is.Arima(hm$auto.arima))
    expect_true(is.ets(hm$ets))
    expect_true("thetam" %in% class(hm$thetam))
    expect_true(is.stlm(hm$stlm))
    expect_true(is.forecast(hm$snaive))

    # Base forecasts should work
    expect_error(forecast(hm$auto.arima, xreg = xreg), NA)
    # Test forecast
    h <- nrow(xreg)
    expect_error(forecast(hm, h = h, xreg = xreg), NA)
    modelComparison[[as.character(parallel)]] <- hm
  }
  # Compare the results from parallel = TRUE and parallel = FALSE
  tol <- 10^-8
  parallelFitted <- modelComparison[["TRUE"]]$fitted
  serialFitted <- modelComparison[["FALSE"]]$fitted
  expect_lt(sum(abs(parallelFitted - serialFitted), na.rm = TRUE), tol)
  expect_true(all(is.na(serialFitted) == is.na(parallelFitted)))

  parallelResiduals <- modelComparison[["TRUE"]]$residuals
  serialResiduals <- modelComparison[["FALSE"]]$residuals
  expect_lt(sum(abs(parallelResiduals - serialResiduals), na.rm = TRUE), tol)
  expect_true(all(is.na(serialResiduals) == is.na(parallelResiduals)))
})

test_that("Testing the weighting methods", {
  inputSeries <- ts(rnorm(100), f = 2)
  tol <- 10^-8
  # Test two quick models since we will be performing cross validation
  models <- "fs"
  weights <- c("equal", "insample.errors", "cv.errors")
  # TODO: add another loop here for errorMethod once MASE with cv.errors is implemented
  results <- list()
  for (weight in weights) {
    if (weight == "insample.errors") {
      expect_warning(hm <- hybridModel(inputSeries, models = models, # nolint: implicit_assignmnet_linter
                                       weights = weight))
    } else {
      hm <- hybridModel(inputSeries, models = models, weights = weight)
    }
    expect_lt(sum(hm$weights) - 1, tol)
    expect_true(all(hm$weights >= 0))
    expect_true(all(hm$weights <= 1))
    expect_length(hm$weights, nchar(models))
    results[[weight]] <- hm
  }
  # Test that weights are not equal
  weightResults <- sapply(results, function(x) x$weights)
  weights <- as.list(data.frame(weightResults))
  expect_true(all(weights$insample.errors != weights$cv.errors))
  expect_true(all(weights$insample.errors != weights$equal))
  expect_true(all(weights$equal != weights$cv.errors))
})

test_that("Testing the hybrid model with xreg", {
  # Test with data from issue #86
  trainSet <- beaver1[1:100, ]
  testSet <- beaver1[- (1:100), ]
  trainXreg <- as.matrix(data.frame(trainSet$activ, trainSet$time))
  beaverhm <- hybridModel(ts(trainSet$temp, f = 6),
                          models = "aenst",
                          a.args = list(xreg = trainXreg),
                          n.args = list(xreg = trainXreg),
                          s.args = list(xreg = trainXreg, method = "arima"))
  expect_true(all.equal(names(beaverhm$xreg), c("auto.arima", "nnetar", "stlm")))
  expect_true(all(unlist(beaverhm$xreg)))
})