tests/testthat/test-accuracy.R

In fabletools: Core Tools for Packages in the 'fable' Framework

context("test-accuracy")

test_that("accuracy() hints", {
  skip_if_not_installed("fable")
  expect_error(
    accuracy(mbl, us_deaths),
    "To compute forecast accuracy, you'll need to compute the forecasts first.",
    fixed = TRUE
  )
})

test_that("In-sample accuracy", {
  skip_if_not_installed("fable")

  expect_warning(
    accuracy(mbl, measures = interval_accuracy_measures),
    'argument ".dist" is missing'
  ) %>%
    {is.na(.[["winkler"]])} %>%
    expect_true()

  acc <- accuracy(mbl)
  expect_equal(acc$.type, "Training")
  expect_equal(dim(acc), c(1,10))
  expect_true(!any(map_lgl(acc, compose(any, is.na))))
  expect_equal(
    as.list(acc),
    as_tibble(augment(mbl)) %>%
      group_by(.model) %>%
      summarise(.type = "Training", ME = mean(.resid), RMSE = sqrt(mean(.resid^2)),
                MAE = mean(abs(.resid)), MPE = mean(.resid/value*100),
                MAPE = mean(abs(.resid/value)*100),
                MASE = MASE(.resid, value, .period = 12),
                RMSSE = RMSSE(.resid, value, .period = 12),
                ACF1 = ACF1(.resid)) %>%
      as.list()
  )

  acc_multi <- accuracy(mbl_multi)
  expect_equal(acc_multi$key, c("fdeaths", "mdeaths"))
  expect_equal(dim(acc_multi), c(2,11))
  expect_true(!any(map_lgl(acc_multi, compose(any, is.na))))

  acc_complex <- accuracy(mbl_complex)
  expect_equal(acc_complex$key, rep(c("fdeaths", "mdeaths"), each = 2))
  expect_equal(acc_complex$.model, rep(c("ets", "lm"), 2))
  expect_equal(dim(acc_complex), c(4,11))
  expect_equal(acc_complex[c(1,3), -2], acc_multi[,-2])
  expect_true(!any(map_lgl(acc_complex, compose(any, is.na))))

  acc_mv <- accuracy(mbl_mv)
  expect_equal(
    acc_mv$.response,
    factor(c("mdeaths", "fdeaths"), levels = unique(c("mdeaths", "fdeaths")))
  )
  expect_true(!any(map_lgl(acc_mv, compose(any, is.na))))
})


test_that("Out-of-sample accuracy", {
  skip_if_not_installed("fable")

  expect_warning(
    accuracy(fbl, utils::head(us_deaths)),
    "12 observations are missing between 1978 Jan and 1978 Dec"
  )

  acc <- accuracy(fbl, us_deaths)
  expect_equal(acc$.type, "Test")
  expect_equal(dim(acc), c(1,10))
  expect_true(!any(map_lgl(acc, compose(any, is.na))))
  expect_equal(
    as.list(acc),
    as_tibble(fbl) %>%
      mutate(
        actual = semi_join(us_deaths, fbl, by = "index")$value,
        .resid = actual - mean(value)
      ) %>%
      group_by(.model) %>%
      summarise(.type = "Test", ME = mean(.resid), RMSE = sqrt(mean(.resid^2)),
                MAE = mean(abs(.resid)), MPE = mean(.resid/actual*100),
                MAPE = mean(abs(.resid/actual)*100),
                MASE = MASE(.resid, us_deaths_tr$value, .period = 12), 
                RMSSE = RMSSE(.resid, us_deaths_tr$value, .period = 12), 
                ACF1 = ACF1(.resid)) %>%
      as.list()
  )

  acc <- accuracy(fbl, us_deaths, measures = list(interval_accuracy_measures, distribution_accuracy_measures))
  expect_equal(acc$.type, "Test")
  expect_equal(colnames(acc), c(".model", ".type", "winkler", "percentile", "CRPS"))
  expect_true(!any(map_lgl(acc, compose(any, is.na))))

  acc_multi <- accuracy(fbl_multi, lung_deaths_long)
  expect_equal(acc_multi$key, c("fdeaths", "mdeaths"))
  expect_equal(dim(acc_multi), c(2,11))
  expect_true(!any(map_lgl(acc_multi, compose(any, is.na))))

  acc_complex <- accuracy(fbl_complex, lung_deaths_long)

  expect_equal(acc_complex$key, rep(c("fdeaths", "mdeaths"), 2))
  expect_equal(acc_complex$.model, rep(c("ets", "lm"), each = 2))
  expect_equal(dim(acc_complex), c(4,11))
  expect_equal(acc_complex[1:2, -(1:2)], acc_multi[,-(1:2)])
  expect_true(!any(map_lgl(acc_complex, compose(any, is.na))))

  acc_mv <- accuracy(fbl_mv, lung_deaths_wide)
  expect_equal(
    acc_mv$.response,
    c("fdeaths", "mdeaths")
  )
  expect_true(!any(map_lgl(acc_mv, compose(any, is.na))))
})