1210: Fix plot_correlations() heatmap misalignment with non-default metrics order

NEWS.md

@@ -1,5 +1,6 @@
 # scoringutils (development version)
 
+- Fixed `plot_correlations()` producing a misaligned heatmap (including a diagonal not equal to 1) when the correlations were computed with `get_correlations(scores, metrics = ...)` using a non-default metric order. `get_correlations()` now returns rows and columns in the requested `metrics` order, and `plot_correlations()` aligns rows explicitly via the `metric` column instead of relying on positional order (#1210).
 - 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).

R/get-correlations.R

@@ -15,7 +15,7 @@
 #' @importFrom data.table setDT
 #' @importFrom stats cor na.omit
 #' @importFrom cli cli_warn
-#' @importFrom checkmate assert_subset
+#' @importFrom checkmate assert_character assert_subset
 #' @export
 #' @keywords scoring
 #' @examples
@@ -30,7 +30,8 @@ get_correlations <- function(scores,
                              ...) {
   scores <- ensure_data.table(scores)
   assert_subset(metrics, colnames(scores), empty.ok = FALSE)
-  df <- scores[, .SD, .SDcols = names(scores) %in% metrics]
+  assert_character(metrics, unique = TRUE)
+  df <- scores[, .SD, .SDcols = metrics]
 
   # define correlation matrix
   cor_mat <- cor(as.matrix(df), ...)
@@ -77,16 +78,13 @@ plot_correlations <- function(correlations, digits = NULL) {
   assert_data_frame(correlations)
   metrics <- get_metrics.scores(correlations, error = TRUE)
 
-  lower_triangle <- get_lower_tri(correlations[, .SD, .SDcols = metrics])
-
-  if (!is.null(digits)) {
-    lower_triangle <- round(lower_triangle, digits)
-  }
-
-
   # check correlations is actually a matrix of correlations
   col_present <- check_subset("metric", colnames(correlations))
-  if (any(lower_triangle > 1, na.rm = TRUE) || !isTRUE(col_present)) {
+  values_above_one <- any(
+    correlations[, .SD, .SDcols = metrics] > 1,
+    na.rm = TRUE
+  )
+  if (values_above_one || !isTRUE(col_present)) {
     cli_abort(
       c(
         "Found correlations > 1 or missing `metric` column.",
@@ -95,7 +93,16 @@ plot_correlations <- function(correlations, digits = NULL) {
     )
   }
 
-  rownames(lower_triangle) <- colnames(lower_triangle)
+  # align rows and columns with the order given by `metrics`
+  cor_mat <- as.matrix(correlations[, .SD, .SDcols = metrics])
+  rownames(cor_mat) <- correlations$metric
+  cor_mat <- cor_mat[metrics, , drop = FALSE]
+
+  lower_triangle <- get_lower_tri(cor_mat)
+
+  if (!is.null(digits)) {
+    lower_triangle <- round(lower_triangle, digits)
+  }
 
   # get plot data.frame
   plot_df <- as.data.table(lower_triangle)[, metric := metrics]

tests/testthat/test-get-correlations.R

@@ -30,6 +30,30 @@ test_that("get_correlations() works as expected", {
     get_correlations(as.data.frame(as.matrix(scores_quantile))),
     "Assertion on 'metrics' failed: Must be a subset of"
   )
+
+  # check we get an error if `metrics` contains duplicates
+  expect_error(
+    get_correlations(scores_quantile, metrics = c("wis", "wis", "bias")),
+    "Assertion on 'metrics' failed: Contains duplicated values"
+  )
+})
+
+test_that("get_correlations() respects the order of the `metrics` argument", {
+  m <- rev(get_metrics.scores(scores_quantile))
+  correlations <- get_correlations(
+    summarise_scores(scores_quantile),
+    metrics = m
+  )
+  # columns, rows and the stored attribute all share the requested order
+  expect_identical(colnames(correlations), c(m, "metric"))
+  expect_identical(correlations$metric, m)
+  expect_identical(get_metrics.scores(correlations), m)
+  # the diagonal of the correlation matrix is 1
+  expect_equal(
+    diag(as.matrix(correlations[, .SD, .SDcols = m])),
+    rep(1, length(m)),
+    ignore_attr = TRUE
+  )
 })
 
 # ==============================================================================
@@ -53,3 +77,81 @@ test_that("plot_correlations() works as expected", {
     "Did you forget to call `scoringutils::get_correlations()`?"
   )
 })
+
+test_that("plot_correlations() aligns cells with non-default metrics order", {
+  summarised <- summarise_scores(scores_quantile)
+  m <- rev(get_metrics.scores(scores_quantile))
+  correlations <- get_correlations(summarised, metrics = m)
+  p <- plot_correlations(correlations, digits = 2)
+  pd <- data.table::as.data.table(p$data)
+
+  # the diagonal of the plotted heatmap must be 1
+  expect_true(
+    all(pd[as.character(metric) == as.character(variable)]$value == 1)
+  )
+
+  # every plotted cell must match the true correlation matrix
+  true_cor <- stats::cor(as.matrix(summarised[, .SD, .SDcols = m]))
+  expect_equal(
+    pd$value,
+    round(
+      true_cor[cbind(as.character(pd$metric), as.character(pd$variable))],
+      2
+    ),
+    ignore_attr = TRUE
+  )
+
+  # same checks with a subset of metrics in non-default order
+  m_subset <- c("dispersion", "wis", "bias")
+  correlations_subset <- get_correlations(summarised, metrics = m_subset)
+  p_subset <- plot_correlations(correlations_subset, digits = 2)
+  pd_subset <- data.table::as.data.table(p_subset$data)
+  expect_true(
+    all(
+      pd_subset[as.character(metric) == as.character(variable)]$value == 1
+    )
+  )
+  true_cor_subset <- stats::cor(
+    as.matrix(summarised[, .SD, .SDcols = m_subset])
+  )
+  expect_equal(
+    pd_subset$value,
+    round(
+      true_cor_subset[
+        cbind(as.character(pd_subset$metric), as.character(pd_subset$variable))
+      ],
+      2
+    ),
+    ignore_attr = TRUE
+  )
+})
+
+test_that("plot_correlations() aligns rows of a row-scrambled input", {
+  # simulate an object created by the pre-fix get_correlations():
+  # rows (and the `metric` column) in data-column order, but the `metrics`
+  # attribute in a different, user-supplied order
+  summarised <- summarise_scores(scores_quantile)
+  data_order <- get_metrics.scores(scores_quantile)
+  m <- rev(data_order)
+  true_cor <- stats::cor(as.matrix(summarised[, .SD, .SDcols = data_order]))
+  scrambled <- data.table::as.data.table(true_cor)[, metric := data_order]
+  attr(scrambled, "metrics") <- m
+
+  p <- plot_correlations(scrambled, digits = 2)
+  pd <- data.table::as.data.table(p$data)
+
+  # the diagonal of the plotted heatmap must be 1
+  expect_true(
+    all(pd[as.character(metric) == as.character(variable)]$value == 1)
+  )
+
+  # every plotted cell must match the true correlation matrix
+  expect_equal(
+    pd$value,
+    round(
+      true_cor[cbind(as.character(pd$metric), as.character(pd$variable))],
+      2
+    ),
+    ignore_attr = TRUE
+  )
+})