tests/testthat/test-metrics.R

In tsaux: Time Series Forecasting Auxiliary Functions

actual <- c(100, 200, 300, 400, 500)
predicted <- c(110, 190, 290, 410, 490)
weights <- c(0.1, 0.2, 0.2, 0.3, 0.2)

set.seed(42)
distribution <- matrix(rnorm(500, mean = rep(actual, each = 100), sd = 15), nrow = 100, ncol = length(actual))

test_that("MAPE is computed correctly", {
  expected_mape <- mean(abs((actual - predicted) / actual))
  expect_equal(mape(actual, predicted), expected_mape, tolerance = 1e-6)
})

test_that("RMAPE does not return errors", {
  expect_silent(rmape(actual, predicted))
})

test_that("SMAPE is computed correctly", {
  expected_smape <- mean(2 * abs(actual - predicted) / (abs(actual) + abs(predicted)))
  expect_equal(smape(actual, predicted), expected_smape, tolerance = 1e-6)
})

test_that("MASE handles basic case correctly", {
  original_series <- c(90, 180, 270, 360, 450, 540)
  frequency <- 1
  expect_silent(mase(actual, predicted, original_series, frequency))
})

test_that("MSLRE is computed correctly", {
  valid <- actual > 0 & predicted > 0
  expected_mslre <- mean((log(1 + actual[valid]) - log(1 + predicted[valid]))^2)
  expect_equal(mslre(actual, predicted), expected_mslre, tolerance = 1e-6)
})

test_that("Bias is computed correctly", {
  expected_bias <- mean(predicted - actual)
  expect_equal(bias(actual, predicted), expected_bias, tolerance = 1e-6)
})

test_that("WAPE handles weights correctly", {
  expected_wape <- sum(weights * abs(predicted - actual) / actual)
  expect_equal(wape(actual, predicted, weights), expected_wape, tolerance = 1e-6)
})

test_that("WSLRE handles weights correctly", {
  valid <- actual > 0 & predicted > 0
  expected_wslre <- sum(weights * (log(predicted[valid] / actual[valid]))^2)
  expect_equal(wslre(actual, predicted, weights), expected_wslre, tolerance = 1e-6)
})

test_that("WSE handles weights correctly", {
  expected_wse <- sum(weights * (predicted / actual)^2)
  expect_equal(wse(actual, predicted, weights), expected_wse, tolerance = 1e-6)
})

test_that("Pinball Loss handles sample x horizon distribution correctly", {
  tau <- 0.1
  expected_loss <- mean(ifelse(actual >= apply(distribution, 2, quantile, probs = tau),
                               tau * (actual - apply(distribution, 2, quantile, probs = tau)),
                               (1 - tau) * (apply(distribution, 2, quantile, probs = tau) - actual)))
  expect_equal(pinball(actual, distribution, tau), expected_loss, tolerance = 1e-6)
})

test_that("CRPS handles sample x horizon distribution correctly", {
  # Check CRPS runs correctly and does not produce errors
  expect_silent(crps(actual, distribution))
})

test_that("MIS does not return errors", {
  lower <- actual - 20
  upper <- actual + 20
  alpha <- 0.05
  expect_silent(mis(actual, lower, upper, alpha))
})

test_that("MSIS handles sample x horizon distribution correctly", {
  lower <- actual - 20
  upper <- actual + 20
  original_series <- c(90, 180, 270, 360, 450, 540)
  frequency <- 1
  alpha <- 0.05
  expect_silent(msis(actual, lower, upper, original_series, frequency, alpha))
})