Fixes #188

NEWS.md

@@ -2,6 +2,8 @@
 
 * Fixed `cal_plot_breaks()`, `cal_plot_logistic()`, and `cal_plot_windowed()` so that plots of tuning results with more than one model configuration can be rendered. The grouping column was dropped before the plot was faceted (#202).
 
+* Fixed `cal_plot_breaks()`, `cal_plot_logistic()`, and `cal_plot_windowed()` so that the rug layers are included when the `.by` argument is used. The rug is colored by the grouping variable (#188).
+
 # probably 1.2.0
 
 * Add `required_pkgs()` methods to `int_conformal_cv()`, `int_conformal_full()`, `int_conformal_quantile()`,  and `int_conformal_split()`. (#190)

R/cal-plot-utils.R

@@ -318,6 +318,7 @@ cal_plot_impl <- function(
     grouping_var <- tbl[, gp_vars][[1]]
     if (is.numeric(grouping_var)) {
       tbl[, gp_vars] <- as.factor(format(grouping_var))
+      .data[, gp_vars] <- as.factor(format(.data[, gp_vars][[1]]))
     }
   } else {
     has_groups <- FALSE
@@ -344,7 +345,7 @@ cal_plot_impl <- function(
       )
   }
 
-  if (include_rug & !has_groups & !length(tbl_groups) & !is_tune_results) {
+  if (include_rug & !length(tbl_groups) & !is_tune_results) {
     levels <- truth_estimate_map(
       .data = .data,
       truth = !!truth,
@@ -363,8 +364,17 @@ cal_plot_impl <- function(
     side_values <- c("t", "b")
     for (i in seq_along(truth_values)) {
       level_tbl <- dplyr::filter(.data, as.integer(!!truth) == truth_values[i])
-      res <- res +
-        geom_rug(
+      if (has_groups) {
+        rug_layer <- geom_rug(
+          data = level_tbl,
+          aes(x = !!level1, color = !!dplyr_group),
+          sides = side_values[i],
+          length = unit(0.015, "npc"),
+          alpha = 0.7,
+          show.legend = FALSE
+        )
+      } else {
+        rug_layer <- geom_rug(
           data = level_tbl,
           aes(x = !!level1),
           color = "#999999",
@@ -373,6 +383,8 @@ cal_plot_impl <- function(
           alpha = 0.7,
           show.legend = FALSE
         )
+      }
+      res <- res + rug_layer
     }
   }
 

tests/testthat/test-cal-plot-breaks.R

@@ -70,7 +70,7 @@ test_that("Binary breaks functions work with group argument", {
 
   expect_snapshot(get_labs(res))
 
-  expect_equal(length(res$layers), 4)
+  expect_equal(length(res$layers), 6)
 
   expect_snapshot_error(
     segment_logistic |>
@@ -79,6 +79,38 @@ test_that("Binary breaks functions work with group argument", {
   )
 })
 
+test_that("rug layers are included when using the group argument (#188)", {
+  grouped <- segment_logistic |>
+    dplyr::mutate(id = dplyr::row_number() %% 2)
+
+  rug_layers <- function(x) {
+    Filter(\(y) inherits(y$geom, "GeomRug"), x$layers)
+  }
+
+  res <- cal_plot_breaks(grouped, Class, .pred_good, .by = id)
+  rugs <- rug_layers(res)
+
+  expect_equal(length(rugs), 2)
+  expect_equal(
+    unname(purrr::map_chr(rugs, \(x) x$geom_params$sides)),
+    c("t", "b")
+  )
+  # the rug is colored by the grouping variable, which has to be a factor to
+  # match the color scale used by the other layers
+  expect_equal(
+    unname(purrr::map_chr(rugs, \(x) rlang::expr_text(x$mapping$colour))),
+    rep("~id", 2)
+  )
+  expect_true(all(purrr::map_lgl(rugs, \(x) is.factor(x$data$id))))
+
+  expect_equal(
+    length(rug_layers(
+      cal_plot_breaks(grouped, Class, .pred_good, .by = id, include_rug = FALSE)
+    )),
+    0
+  )
+})
+
 test_that("Multi-class breaks functions work", {
   skip_if_not_installed("modeldata")
 

tests/testthat/test-cal-plot-logistic.R

@@ -148,7 +148,7 @@ test_that("Binary logistic functions work with group argument", {
 
   expect_snapshot(get_labs(res))
 
-  expect_equal(length(res$layers), 3)
+  expect_equal(length(res$layers), 5)
 
   expect_snapshot_error(
     segment_logistic |>