diff --git a/NEWS.md b/NEWS.md index e1ee239eb..af8a70cae 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # scoringutils (development version) +- Fixed `rps_ordinal()` and `logs_categorical()` returning wrong scores when called directly with a `predicted_label` that was not in the order of the factor levels: `rps_ordinal()` applied the wrong (forward instead of inverse) permutation when reordering the columns of `predicted`, and `logs_categorical()` ignored `predicted_label` entirely. Scores are now invariant to how the columns of `predicted` are labelled. Forecasts scored via `score()` were unaffected, as the pipeline sorts predictions into level order before calling the metrics. Additionally, input validation for categorical forecasts now errors when `predicted` has more or fewer columns than there are factor levels for inputs with more than one observation (previously such input was silently accepted and scored meaninglessly; the check already existed for a single observation) (#1200). - Added `filter_scores()` and `impute_missing_scores()` for handling missing forecasts before summarisation. `filter_scores()` removes target combinations with insufficient model coverage, while `impute_missing_scores()` fills in missing scores using configurable strategies (worst, mean, NA, or reference model). Both use a strategy function pattern for extensibility. See `vignette("handling-missing-forecasts")` for details (#1122). - Added `plot_discrimination()` to visualise the discrimination ability of binary forecasts by plotting the distribution of predicted probabilities, stratified by the observed outcome. The function requires a `forecast_binary` object (created with `as_forecast_binary()`) (#942). - Fixed `summarise_scores()` producing a data.table with duplicate column names when the input `scores` object had no score columns (e.g. because every metric in `score()` warned and returned nothing). `summarise_scores()` now matches metric columns by exact name rather than regex partial match, and errors with a clear message when there is nothing to summarise (#1179). diff --git a/R/metrics-nominal.R b/R/metrics-nominal.R index ca5dd0c6d..995398749 100644 --- a/R/metrics-nominal.R +++ b/R/metrics-nominal.R @@ -69,7 +69,7 @@ assert_input_categorical <- function( ) summed_predictions <- .rowSums(predicted, m = 1, n = N, na.rm = TRUE) } else { - assert_matrix(predicted, nrows = n) + assert_matrix(predicted, nrows = n, ncols = N) summed_predictions <- round(rowSums(predicted, na.rm = TRUE), 10) # avoid numeric errors } # Allow for numeric errors @@ -130,6 +130,11 @@ logs_categorical <- function(observed, predicted, predicted_label) { if (n == 1) { predicted <- matrix(predicted, nrow = 1) } + # Reorder the predicted matrix columns to match the natural level order: + # column k of `predicted` holds probabilities for level + # `as.numeric(predicted_label)[k]`, so the inverse permutation given by + # `order()` puts the column for level k into position k + predicted <- predicted[, order(as.numeric(predicted_label)), drop = FALSE] observed_indices <- as.numeric(observed) pred_for_observed <- predicted[cbind(1:n, observed_indices)] logs <- -log(pred_for_observed) diff --git a/R/metrics-ordinal.R b/R/metrics-ordinal.R index 03e87e191..2d7a3b3f5 100644 --- a/R/metrics-ordinal.R +++ b/R/metrics-ordinal.R @@ -71,9 +71,12 @@ rps_ordinal <- function(observed, predicted, predicted_label) { predicted <- matrix(predicted, nrow = 1) } - # Reorder the predicted matrix columns to match the natural ordering - correct_order <- as.numeric(predicted_label) - ordered_predicted <- predicted[, correct_order] + # Reorder the predicted matrix columns to match the natural level order: + # column k of `predicted` holds probabilities for level + # `as.numeric(predicted_label)[k]`, so the inverse permutation given by + # `order()` puts the column for level k into position k + ordered_predicted <- + predicted[, order(as.numeric(predicted_label)), drop = FALSE] rps <- rps_probs(as.numeric(observed), ordered_predicted) return(rps) diff --git a/tests/testthat/test-metrics-nominal.R b/tests/testthat/test-metrics-nominal.R index 0167a896a..01fc68185 100644 --- a/tests/testthat/test-metrics-nominal.R +++ b/tests/testthat/test-metrics-nominal.R @@ -93,6 +93,21 @@ test_that("Input checking for nominal forecasts works", { expect_no_condition( assert_input_nominal(observed, predicted2, predicted_label) ) + + # n > 1 with wrong number of columns + predicted_wide <- matrix( + c( + 0.2, 0.1, 0.4, 0.3, + 0.1, 0.25, 0.25, 0.4, + 0.25, 0.25, 0.25, 0.25 + ), + nrow = 3, + byrow = TRUE + ) + expect_error( + assert_input_nominal(observed, predicted_wide, predicted_label), + "Must have exactly 3 cols, but has 4 cols" + ) }) @@ -139,3 +154,16 @@ test_that("logs_categorical() works as expected", { c(NA, res_manual[-1]) ) }) + +test_that("logs_categorical() is invariant to permutations of predicted_label", { + perm <- c(2, 3, 1) + predicted_label2 <- factor(factor_levels[perm], levels = factor_levels) + res <- logs_categorical(observed, predicted[, perm], predicted_label2) + expect_equal( # nolint: expect_identical_linter + res, + logs_categorical(observed, predicted, predicted_label) + ) + # explicitly -log() of the probability assigned to the observed outcome + res_manual <- -log(c(predicted[1, 1], predicted[2, 2], predicted[3, 2])) + expect_equal(res, res_manual) # nolint: expect_identical_linter +}) diff --git a/tests/testthat/test-metrics-ordinal.R b/tests/testthat/test-metrics-ordinal.R index cc3e5f9f0..20471aeff 100644 --- a/tests/testthat/test-metrics-ordinal.R +++ b/tests/testthat/test-metrics-ordinal.R @@ -120,10 +120,24 @@ test_that("rps_ordinal() works as expected", { expect_equal(res, result) # nolint: expect_identical_linter # works with changed order of levels + # column k of `predicted` holds probabilities for predicted_label2[k], so + # the columns in natural level order are given by the inverse permutation + # order(c(3, 1, 2)) = c(2, 3, 1) predicted_label2 <- factor(c("three", "one", "two"), levels = factor_levels, ordered = TRUE) expect_equal( # nolint: expect_identical_linter rps_ordinal(observed, predicted, predicted_label2), - scoringRules::rps_probs(as.numeric(observed), predicted[, c(3, 1, 2)]) + scoringRules::rps_probs(as.numeric(observed), predicted[, order(c(3, 1, 2))]) + ) +}) + +test_that("rps_ordinal() is invariant to permutations of predicted_label", { + perm <- c(2, 3, 1) + predicted_label2 <- factor( + factor_levels[perm], levels = factor_levels, ordered = TRUE + ) + expect_equal( # nolint: expect_identical_linter + rps_ordinal(observed, predicted[, perm], predicted_label2), + rps_ordinal(observed, predicted, predicted_label) ) })