guide_coloursteps(even.steps = FALSE) works with discrete data (#5783)

* discard uneven steps warning

* simplify `extract_decor()`

* take literal breaks as `.value` if uneven steps

* replace individual attribute with the parsed result

* add test

* add news bullet

* fix parsed attribute bug

Author: teunbrand

NEWS.md

@@ -29,6 +29,8 @@
 * When legends detect the presence of values in a layer, `NA` is now detected
   if the data contains values outside the given breaks (@teunbrand, #5749).
 * `annotate()` now warns about `stat` or `position` arguments (@teunbrand, #5151)
+* `guide_coloursteps(even.steps = FALSE)` now works with discrete data that has 
+  been formatted by `cut()` (@teunbrand, #3877).
 
 # ggplot2 3.5.0
 

R/guide-bins.R

@@ -326,8 +326,7 @@ GuideBins <- ggproto(
   }
 )
 
-parse_binned_breaks = function(scale, breaks = scale$get_breaks(),
-                               even.steps = TRUE) {
+parse_binned_breaks = function(scale, breaks = scale$get_breaks()) {
 
   breaks <- breaks[!is.na(breaks)]
   if (length(breaks) == 0) {
@@ -343,12 +342,6 @@ parse_binned_breaks = function(scale, breaks = scale$get_breaks(),
     all_breaks <- unique0(c(limits[1], breaks, limits[2]))
     bin_at <- all_breaks[-1] - diff(all_breaks) / 2
   } else {
-    if (isFALSE(even.steps)) {
-      cli::cli_warn(paste0(
-        "{.code even.steps = FALSE} is not supported when used with a ",
-        "discrete scale."
-      ))
-    }
     bin_at <- breaks
     nums   <- as.character(breaks)
     nums   <- strsplit(gsub("\\(|\\)|\\[|\\]", "", nums), ",\\s?")

R/guide-colorsteps.R

@@ -98,15 +98,19 @@ GuideColoursteps <- ggproto(
       return(Guide$extract_key(scale, aesthetic))
     }
 
-    parsed <- parse_binned_breaks(scale, breaks, even.steps)
+    parsed <- parse_binned_breaks(scale, breaks)
     if (is.null(parsed)) {
       return(parsed)
     }
     limits <- parsed$limits
     breaks <- parsed$breaks
 
     key <- data_frame0(!!aesthetic := scale$map(breaks))
-    key$.value <- seq_along(breaks)
+    if (even.steps) {
+      key$.value <- seq_along(breaks)
+    } else {
+      key$.value <- breaks
+    }
     key$.label <- scale$get_labels(breaks)
 
     if (breaks[1] %in% limits) {
@@ -117,35 +121,34 @@ GuideColoursteps <- ggproto(
       key[[1]][nrow(key)] <- NA
     }
     # To avoid having to recalculate these variables in other methods, we
-    # attach these as attributes. It might not be very elegant, but it works.
-    attr(key, "limits") <- parsed$limits
-    attr(key, "bin_at") <- parsed$bin_at
-    return(key)
+    # attach the parsed values as attributes. It might not be very elegant,
+    # but it works.
+    attr(key, "parsed") <- parsed
+    key
   },
 
   extract_decor = function(scale, aesthetic, key,
                            reverse = FALSE, even.steps = TRUE,
                            nbin = 100, alpha = NA,...) {
+
+    parsed <- attr(key, "parsed")
+    breaks <- parsed$breaks %||% scale$get_breaks()
+    limits <- parsed$limits %||% scale$get_limits()
+
+    breaks <- sort(unique0(c(limits, breaks)))
+    n      <- length(breaks)
+    bin_at <- parsed$bin_at %||% ((breaks[-1] + breaks[-n]) / 2)
+
     if (even.steps) {
-      bin_at <- attr(key, "bin_at", TRUE)
-      bar <- data_frame0(
-        colour = alpha(scale$map(bin_at), alpha),
-        min    = seq_along(bin_at) - 1,
-        max    = seq_along(bin_at),
-        .size  = length(bin_at)
-      )
-    } else {
-      breaks <- unique(sort(c(scale$get_limits(), scale$get_breaks())))
-      n <- length(breaks)
-      bin_at <- (breaks[-1] + breaks[-n]) / 2
-      bar <- data_frame0(
-        colour = alpha(scale$map(bin_at), alpha),
-        min    = head(breaks, -1),
-        max    = tail(breaks, -1),
-        .size  = length(bin_at)
-      )
+      breaks <- seq_len(n) - 1L
     }
-    return(bar)
+
+    data_frame0(
+      colour = alpha(scale$map(bin_at), alpha),
+      min    = breaks[-n],
+      max    = breaks[-1],
+      .size  = length(bin_at)
+    )
   },
 
   extract_params = function(scale, params, direction = "vertical", title = waiver(), ...) {
@@ -166,7 +169,7 @@ GuideColoursteps <- ggproto(
 
     if (show.limits) {
       key <- params$key
-      limits <- attr(key, "limits", TRUE) %||% scale$get_limits()
+      limits <- attr(key, "parsed")$limits %||% scale$get_limits()
       key <- key[c(NA, seq_len(nrow(key)), NA), , drop = FALSE]
       n <- nrow(key)
       key$.value[c(1, n)] <- range(params$decor$min, params$decor$max)

tests/testthat/test-guides.R

@@ -302,6 +302,21 @@ test_that("guide_coloursteps and guide_bins return ordered breaks", {
   expect_true(all(diff(key$.value) > 0))
 })
 
+test_that("guide_coloursteps can parse (un)even steps from discrete scales", {
+
+  val <- cut(1:10, breaks = c(0, 3, 5, 10), include.lowest = TRUE)
+  scale <- scale_colour_viridis_d()
+  scale$train(val)
+
+  g <- guide_coloursteps(even.steps = TRUE)
+  decor <- g$train(scale = scale, aesthetics = "colour")$decor
+  expect_equal(decor$max - decor$min, rep(1/3, 3))
+
+  g <- guide_coloursteps(even.steps = FALSE)
+  decor <- g$train(scale = scale, aesthetics = "colour")$decor
+  expect_equal(decor$max - decor$min, c(0.3, 0.2, 0.5))
+})
+
 
 test_that("guide_colourbar merging preserves both aesthetics", {
   # See issue 5324