Guarantee square interactive calibration panel

R/zzz_calibration_aspect.R

@@ -0,0 +1,29 @@
+# Keep the upper interactive calibration panel on a 1:1 predicted/observed scale.
+#
+# The histogram is a separate lower subplot and intentionally remains
+# unconstrained.  This wrapper is loaded after calibration.R so the plotting
+# implementation itself stays unchanged apart from the final Plotly layout.
+
+.create_plotly_curve_from_calibration_curve_list_unconstrained <-
+  create_plotly_curve_from_calibration_curve_list
+
+create_plotly_curve_from_calibration_curve_list <- function(calibration_curve_list,
+                                                             type = "discrete") {
+  calibration_curve <-
+    .create_plotly_curve_from_calibration_curve_list_unconstrained(
+      calibration_curve_list,
+      type = type
+    )
+
+  calibration_curve |>
+    plotly::layout(
+      yaxis = list(
+        title = "Observed",
+        range = calibration_curve_list$axes_ranges$yaxis,
+        showgrid = FALSE,
+        scaleanchor = "x",
+        scaleratio = 1,
+        constrain = "domain"
+      )
+    )
+}

tests/testthat/test-calibration-interactive-aspect.R

@@ -0,0 +1,23 @@
+test_that("interactive calibration main panel is square", {
+  probs <- list(model = seq(0.05, 0.95, length.out = 20))
+  reals <- list(rep(c(0, 1), 10))
+
+  for (type in c("discrete", "smooth")) {
+    fig <- create_calibration_curve(
+      probs = probs,
+      reals = reals,
+      type = type,
+      interactive = TRUE
+    )
+
+    built <- plotly::plotly_build(fig)
+
+    expect_equal(built$x$layout$xaxis$range, built$x$layout$yaxis$range)
+    expect_equal(built$x$layout$yaxis$scaleanchor, "x")
+    expect_equal(built$x$layout$yaxis$scaleratio, 1)
+    expect_equal(built$x$layout$yaxis$constrain, "domain")
+
+    # The histogram uses yaxis2 and is intentionally not square-constrained.
+    expect_null(built$x$layout$yaxis2$scaleanchor)
+  }
+})