Merge pull request #802 from epiforecasts/add-tests-score

Issues #502 and #587- Add additional tests

R/correlations.R

@@ -48,7 +48,7 @@ get_correlations <- function(scores,
   return(correlations[])
 }
 
-# define function to obtain upper triangle of matrix
+# helper function to obtain upper triangle of matrix
 get_lower_tri <- function(cormat) {
   cormat[lower.tri(cormat)] <- NA
   return(cormat)

tests/testthat/test-convenience-functions.R

@@ -1,3 +1,7 @@
+# ============================================================================ #
+# `transform_forecasts()`
+# ============================================================================ #
+
 test_that("function transform_forecasts works", {
   predictions_original <- example_quantile$predicted
   predictions <- example_quantile %>%
@@ -59,6 +63,11 @@ test_that("transform_forecasts() outputs an object of class forecast_*", {
   expect_s3_class(transformed, "forecast_binary")
 })
 
+
+# ============================================================================ #
+# `log_shift()`
+# ============================================================================ #
+
 test_that("log_shift() works as expected", {
   expect_equal(log_shift(1:10, 1), log(1:10 + 1))
 
@@ -76,6 +85,15 @@ test_that("log_shift() works as expected", {
 
   # test that it does not accept a complex number
   expect_error(log_shift(1:10, offset = 1, base = 1i))
+
+  # test that it does not accept a negative base
+  expect_error(
+    log_shift(1:10, offset = 1, base = -1),
+    "Assertion on 'base' failed: Element 1 is not >= 0."
+  )
+
+  # test output class is numeric as expected
+  checkmate::expect_class(log_shift(1:10, 1), "numeric")
 })
 
 
@@ -109,11 +127,17 @@ test_that("set_forecast_unit() works on input that's not a data.table", {
     colnames(set_forecast_unit(df, c("a", "b"))),
     c("a", "b")
   )
-  # apparently it also works on a matrix... good to know :)
+
   expect_equal(
     names(set_forecast_unit(as.matrix(df), "a")),
     "a"
   )
+
+  expect_s3_class(
+    set_forecast_unit(df, c("a", "b")),
+    c("data.table", "data.frame"),
+    exact = TRUE
+  )
 })
 
 test_that("set_forecast_unit() revalidates a forecast object", {
@@ -145,20 +169,11 @@ test_that("function get_forecast_unit() and set_forecast_unit() work together",
   expect_equal(fu_set, fu_get)
 })
 
-
-test_that("set_forecast_unit() works on input that's not a data.table", {
-  df <- data.frame(
-    a = 1:2,
-    b = 2:3,
-    c = 3:4
-  )
-  expect_equal(
-    colnames(set_forecast_unit(df, c("a", "b"))),
-    c("a", "b")
-  )
-  # apparently it also works on a matrix... good to know :)
+test_that("output class of set_forecast_unit() is as expected", {
+  ex <- as_forecast(na.omit(example_binary))
   expect_equal(
-    names(set_forecast_unit(as.matrix(df), "a")),
-    "a"
+    class(ex),
+    class(set_forecast_unit(ex, c("location", "target_end_date", "target_type", "horizon", "model")))
   )
 })
+

tests/testthat/test-customise_metric.R

@@ -1,55 +0,0 @@
-test_that("customise_metric works correctly", {
-  # Create a customised metric function
-  custom_metric <- customise_metric(mean, na.rm = TRUE)
-
-  # Use the customised metric function
-  values <- c(1, 2, NA, 4, 5)
-  expect_equal(custom_metric(values), 3)
-
-  # Test with a different metric function
-  custom_metric <- customise_metric(sum, na.rm = TRUE)
-  expect_equal(custom_metric(values), 12)
-
-  # Test with no additional arguments
-  custom_metric <- customise_metric(mean)
-  expect_true(is.na(custom_metric(values)))
-
-  # make sure that customise_metric fails immediately (instead of at runtime)
-  # when object doesn't exist
-  expect_error(
-    custom_metric <- customise_metric(print, x = doesnotexist),
-    "object 'doesnotexist' not found"
-  )
-
-  # make sure that customise_metric still works even if original object is
-  # deleted, meaning that the object is stored as part of the function
-  argument <- c("hi", "hello", "I'm here")
-  custom_metric <- customise_metric(print, x = argument)
-  expect_output(custom_metric(), "I'm here")
-
-  argument <- NULL
-  expect_output(custom_metric(), "I'm here")
-
-  # make sure that all of this still works even if argument is called "dots"
-  # which is used internally
-  dots <- "test"
-  expect_output(
-    # dots argument should be ignored and output should stay the same
-    expect_equal(custom_metric(dots = dots), c("hi", "hello", "I'm here")),
-    "I'm here"
-  )
-})
-
-
-
-test_that("customise_metric handles errors correctly", {
-  # Test with a non-function metric
-  expect_error(
-    customise_metric("not_a_function", na.rm = TRUE),
-    "Must be a function, not 'character'"
-  )
-})
-
-test_that("customise_metric is exported", {
-  expect_equal(customise_metric, customise_metric)
-})

tests/testthat/test-default-scoring-rules.R

@@ -1,3 +1,7 @@
+# ==============================================================================
+# select_metrics()
+# ==============================================================================
+
 test_that("`select_metrics` works as expected", {
 
   expect_equal(
@@ -31,9 +35,83 @@ test_that("`select_metrics` works as expected", {
     scoringutils:::select_metrics(metrics_point, select = NULL),
     "Assertion on 'metrics' failed: Must be of type 'list', not 'closure'."
   )
+
+  expect_type(
+    scoringutils:::select_metrics(metrics_point(), select = NULL),
+    "list"
+  )
 })
 
 
+# ==============================================================================
+# customise_metric()
+# ==============================================================================
+
+test_that("customise_metric handles errors correctly", {
+  # Test with a non-function metric
+  expect_error(
+    customise_metric("not_a_function", na.rm = TRUE),
+    "Must be a function, not 'character'"
+  )
+})
+
+test_that("customize_metric is exported", {
+  expect_equal(customise_metric, customize_metric)
+})
+
+
+test_that("customise_metric works correctly", {
+  # Create a customised metric function
+  custom_metric <- customise_metric(mean, na.rm = TRUE)
+
+  # Use the customised metric function
+  values <- c(1, 2, NA, 4, 5)
+  expect_equal(custom_metric(values), 3)
+
+  # Test with a different metric function
+  custom_metric <- customise_metric(sum, na.rm = TRUE)
+  expect_equal(custom_metric(values), 12)
+
+  # Test with no additional arguments
+  custom_metric <- customise_metric(mean)
+  expect_true(is.na(custom_metric(values)))
+
+  # make sure that customise_metric fails immediately (instead of at runtime)
+  # when object doesn't exist
+  expect_error(
+    custom_metric <- customise_metric(print, x = doesnotexist),
+    "object 'doesnotexist' not found"
+  )
+
+  # make sure that customise_metric still works even if original object is
+  # deleted, meaning that the object is stored as part of the function
+  argument <- c("hi", "hello", "I'm here")
+  custom_metric <- customise_metric(print, x = argument)
+  expect_output(custom_metric(), "I'm here")
+
+  argument <- NULL
+  expect_output(custom_metric(), "I'm here")
+
+  # make sure that all of this still works even if argument is called "dots"
+  # which is used internally
+  dots <- "test"
+  expect_output(
+    # dots argument should be ignored and output should stay the same
+    expect_equal(custom_metric(dots = dots), c("hi", "hello", "I'm here")),
+    "I'm here"
+  )
+})
+
+test_that("customise_metric() has the expected output class", {
+  custom_metric <- customise_metric(mean, na.rm = TRUE)
+  checkmate::expect_class(custom_metric, "function")
+})
+
+
+# ==============================================================================
+# default scoring rules
+# ==============================================================================
+
 test_that("default rules work as expected", {
 
   expect_true(
@@ -73,4 +151,3 @@ test_that("default rules work as expected", {
     "Must be a subset of"
   )
 })
-

tests/testthat/test-forecast.R

@@ -1,3 +1,7 @@
+# ==============================================================================
+# as_forecast()
+# ==============================================================================
+
 test_that("Running `as_forecast()` twice returns the same object", {
   ex <- na.omit(example_sample_continuous)
 
@@ -13,7 +17,11 @@ test_that("as_forecast works with a data.frame", {
 
 test_that("as_forecast() works as expected", {
   test <- na.omit(data.table::copy(example_quantile))
-  expect_s3_class(as_forecast(test), "forecast_quantile")
+
+  expect_s3_class(
+    as_forecast(test),
+    c("forecast_quantile", "data.table", "data.frame"),
+    exact = TRUE)
 
   # expect error when arguments are not correct
   expect_error(as_forecast(test, observed = 3), "Must be of type 'character'")
@@ -112,25 +120,6 @@ test_that("check_duplicates() works", {
   )
 })
 
-# test_that("as_forecast() function returns a message with NA in the data", {
-#   expect_message(
-#     { check <- as_forecast(example_quantile) },
-#     "\\d+ values for `predicted` are NA"
-#   )
-#   expect_match(
-#     unlist(check$messages),
-#     "\\d+ values for `predicted` are NA"
-#   )
-# })
-
-# test_that("as_forecast() function returns messages with NA in the data", {
-#   example <- data.table::copy(example_quantile)
-#   example[horizon == 2, observed := NA]
-#   check <- suppressMessages(as_forecast(example))
-#
-#   expect_equal(length(check$messages), 2)
-# })
-
 test_that("as_forecast() function throws an error with duplicate forecasts", {
   example <- rbind(example_quantile,
                    example_quantile[1000:1010])
@@ -294,6 +283,11 @@ test_that("validate_forecast() works as expected", {
     out <- validate_forecast(as_forecast(na.omit(example_point)))
   )
   expect_true(!is.null(out))
+
+  expect_equal(
+    validate_forecast(as_forecast(na.omit(example_point))),
+    as_forecast(na.omit(example_point))
+  )
 })