BOT: Fix #942: Add plot_discrimination() for binary forecasts

NAMESPACE

@@ -101,6 +101,7 @@ export(overprediction_quantile)
 export(overprediction_sample)
 export(pit_histogram_sample)
 export(plot_correlations)
+export(plot_discrimination)
 export(plot_forecast_counts)
 export(plot_heatmap)
 export(plot_interval_coverage)
@@ -123,6 +124,7 @@ export(variogram_score_multivariate_point)
 export(wis)
 importFrom(checkmate,assert)
 importFrom(checkmate,assert_character)
+importFrom(checkmate,assert_choice)
 importFrom(checkmate,assert_class)
 importFrom(checkmate,assert_data_frame)
 importFrom(checkmate,assert_data_table)
@@ -179,6 +181,7 @@ importFrom(data.table,setorderv)
 importFrom(ggplot2,.data)
 importFrom(ggplot2,`%+replace%`)
 importFrom(ggplot2,aes)
+importFrom(ggplot2,after_stat)
 importFrom(ggplot2,coord_cartesian)
 importFrom(ggplot2,coord_flip)
 importFrom(ggplot2,element_blank)
@@ -187,6 +190,8 @@ importFrom(ggplot2,element_text)
 importFrom(ggplot2,facet_grid)
 importFrom(ggplot2,facet_wrap)
 importFrom(ggplot2,geom_col)
+importFrom(ggplot2,geom_density)
+importFrom(ggplot2,geom_histogram)
 importFrom(ggplot2,geom_line)
 importFrom(ggplot2,geom_linerange)
 importFrom(ggplot2,geom_polygon)

R/plot-discrimination.R

@@ -0,0 +1,69 @@
+#' @title Plot discrimination for binary forecasts
+#'
+#' @description
+#' Visualise the discrimination ability of binary forecasts by plotting the
+#' distribution of predicted probabilities, stratified by the observed outcome.
+#' A well-discriminating model will show clearly separated distributions for
+#' the two observed levels.
+#'
+#' @param forecast A data.table (or data.frame) containing at least columns
+#'   `observed` (factor with two levels) and `predicted` (numeric probabilities
+#'   between 0 and 1). Typically a `forecast_binary` object or the output of
+#'   [as_forecast_binary()].
+#' @param type Character, either `"histogram"` (default) or `"density"`.
+#'   `"histogram"` shows a histogram with proportions on the y-axis;
+#'   `"density"` shows kernel density curves.
+#' @param ... Additional arguments passed to [ggplot2::geom_histogram()] or
+#'   [ggplot2::geom_density()], depending on `type`. For example, `bins` or
+#'   `binwidth` for histograms, or `bw` and `adjust` for density plots.
+#' @returns A ggplot object showing the distribution of predicted
+#'   probabilities, coloured by observed outcome level.
+#' @importFrom ggplot2 ggplot aes geom_density geom_histogram
+#'   after_stat labs .data
+#' @importFrom checkmate assert assert_data_frame assert_choice
+#' @export
+#' @examples
+#' library(ggplot2)
+#' plot_discrimination(na.omit(example_binary))
+#'
+#' plot_discrimination(na.omit(example_binary), type = "density")
+#'
+#' plot_discrimination(na.omit(example_binary), bins = 10)
+#'
+#' plot_discrimination(na.omit(example_binary)) +
+#'   facet_wrap(~model)
+
+plot_discrimination <- function(forecast, type = c("histogram", "density"), ...) {
+  forecast <- ensure_data.table(forecast)
+  assert(check_columns_present(forecast, c("observed", "predicted")))
+  type <- match.arg(type)
+
+  plot <- ggplot(
+    forecast,
+    aes(x = .data[["predicted"]], fill = .data[["observed"]])
+  )
+
+  if (type == "density") {
+    plot <- plot +
+      geom_density(alpha = 0.5, ...) + # nolint object_usage_linter
+      labs(y = "Density")
+  } else {
+    plot <- plot +
+      geom_histogram( # nolint object_usage_linter
+        aes(y = after_stat( # nolint object_usage_linter
+          ave(count, group, FUN = function(x) x / sum(x)) # nolint object_usage_linter
+        )),
+        position = "identity", alpha = 0.5, ...
+      ) +
+      labs(y = "Proportion")
+  }
+
+  plot <- plot +
+    labs(
+      x = "Predicted probability",
+      fill = "Observed"
+    ) +
+    theme_scoringutils()
+
+  return(plot)
+}

R/z-globalVariables.R

@@ -36,6 +36,7 @@ globalVariables(c(
   "fill_col",
   "forecast_id",
   "g",
+  "group",
   "hist",
   "identifCol",
   "Interval_Score",