diff --git a/NEWS.md b/NEWS.md index 1591b41..439d4fc 100644 --- a/NEWS.md +++ b/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) diff --git a/R/cal-plot-utils.R b/R/cal-plot-utils.R index f33a6f7..8b91db1 100644 --- a/R/cal-plot-utils.R +++ b/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 } } diff --git a/tests/testthat/test-cal-plot-breaks.R b/tests/testthat/test-cal-plot-breaks.R index b3fb6d6..2180cc4 100644 --- a/tests/testthat/test-cal-plot-breaks.R +++ b/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") diff --git a/tests/testthat/test-cal-plot-logistic.R b/tests/testthat/test-cal-plot-logistic.R index e7ce40e..1511542 100644 --- a/tests/testthat/test-cal-plot-logistic.R +++ b/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 |>