diff --git a/NEWS.md b/NEWS.md index e1ee239eb..724b4e4d8 100644 --- a/NEWS.md +++ b/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). diff --git a/R/get-correlations.R b/R/get-correlations.R index beb951da9..badd52db9 100644 --- a/R/get-correlations.R +++ b/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] diff --git a/tests/testthat/test-get-correlations.R b/tests/testthat/test-get-correlations.R index 3253d4e95..0becf23f5 100644 --- a/tests/testthat/test-get-correlations.R +++ b/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 + ) +})