Merge branch 'main' into ecdf_scale_transform

Author: teunbrand

NEWS.md

@@ -2,6 +2,12 @@
 
 * Renamed computed aesthetic in `stat_ecdf()` to `ecdf`, to prevent incorrect
   scale transformations (@teunbrand, #5113 and #5112).
+* Fixed misbehaviour of `draw_key_boxplot()` and `draw_key_crossbar()` with 
+  skewed key aspect ratio (@teunbrand, #5082).
+* `scale_*_binned()` handles zero-range limits more gracefully (@teunbrand, 
+  #5066)
+* Binned scales are now compatible with `trans = "date"` and `trans = "time"` 
+  (@teunbrand, #4217).
 * `ggsave()` warns when multiple `filename`s are given, and only writes to the
   first file (@teunbrand, #5114)
 * Fixed a regression in `geom_hex()` where aesthetics were replicated across 
@@ -12,7 +18,7 @@
   (@teunbrand based on @clauswilke's suggestion #5051).
 * Fixed a regression in `Coord$train_panel_guides()` where names of guides were 
   dropped (@maxsutton, #5063)
-  
+
 # ggplot2 3.4.0
 This is a minor release focusing on tightening up the internals and ironing out
 some inconsistencies in the API. The biggest change is the addition of the 

R/legend-draw.r

@@ -98,39 +98,58 @@ draw_key_blank <- function(data, params, size) {
 #' @export
 #' @rdname draw_key
 draw_key_boxplot <- function(data, params, size) {
-  grobTree(
-    linesGrob(0.5, c(0.1, 0.25)),
-    linesGrob(0.5, c(0.75, 0.9)),
-    rectGrob(height = 0.5, width = 0.75),
-    linesGrob(c(0.125, 0.875), 0.5),
-    gp = gpar(
-      col = data$colour %||% "grey20",
-      fill = alpha(data$fill %||% "white", data$alpha),
-      lwd = (data$linewidth %||% 0.5) * .pt,
-      lty = data$linetype %||% 1,
-      lineend = params$lineend %||% "butt",
-      linejoin = params$linejoin %||% "mitre"
-    ),
-    vp = if (isTRUE(params$flipped_aes)) viewport(angle = -90)
+  gp <- gpar(
+    col = data$colour %||% "grey20",
+    fill = alpha(data$fill %||% "white", data$alpha),
+    lwd = (data$linewidth %||% 0.5) * .pt,
+    lty = data$linetype %||% 1,
+    lineend = params$lineend %||% "butt",
+    linejoin = params$linejoin %||% "mitre"
   )
+
+  if (isTRUE(params$flipped_aes)) {
+    grobTree(
+      linesGrob(c(0.1, 0.25), 0.5),
+      linesGrob(c(0.75, 0.9), 0.5),
+      rectGrob(width = 0.5, height = 0.75),
+      linesGrob(0.5, c(0.125, 0.875)),
+      gp = gp
+    )
+  } else {
+    grobTree(
+      linesGrob(0.5, c(0.1, 0.25)),
+      linesGrob(0.5, c(0.75, 0.9)),
+      rectGrob(height = 0.5, width = 0.75),
+      linesGrob(c(0.125, 0.875), 0.5),
+      gp = gp
+    )
+  }
 }
 
 #' @export
 #' @rdname draw_key
 draw_key_crossbar <- function(data, params, size) {
-  grobTree(
-    rectGrob(height = 0.5, width = 0.75),
-    linesGrob(c(0.125, 0.875), 0.5),
-    gp = gpar(
-      col = data$colour %||% "grey20",
-      fill = alpha(data$fill %||% "white", data$alpha),
-      lwd = (data$linewidth %||% 0.5) * .pt,
-      lty = data$linetype %||% 1,
-      lineend = params$lineend %||% "butt",
-      linejoin = params$linejoin %||% "mitre"
-    ),
-    vp = if (isTRUE(params$flipped_aes)) viewport(angle = -90)
+  gp <- gpar(
+    col = data$colour %||% "grey20",
+    fill = alpha(data$fill %||% "white", data$alpha),
+    lwd = (data$linewidth %||% 0.5) * .pt,
+    lty = data$linetype %||% 1,
+    lineend = params$lineend %||% "butt",
+    linejoin = params$linejoin %||% "mitre"
   )
+  if (isTRUE(params$flipped_aes)) {
+    grobTree(
+      rectGrob(height = 0.75, width = 0.5),
+      linesGrob(0.5, c(0.125, 0.875)),
+      gp = gp
+    )
+  } else {
+    grobTree(
+      rectGrob(height = 0.5, width = 0.75),
+      linesGrob(c(0.125, 0.875), 0.5),
+      gp = gp
+    )
+  }
 }
 
 #' @export

R/scale-.r

@@ -1021,16 +1021,22 @@ ScaleBinned <- ggproto("ScaleBinned", Scale,
       x <- self$rescale(self$oob(x, range = limits), limits)
       breaks <- self$rescale(breaks, limits)
 
-      x_binned <- cut(x, breaks,
-        labels = FALSE,
-        include.lowest = TRUE,
-        right = self$right
-      )
+      if (length(breaks) > 1) {
+        x_binned <- cut(x, breaks,
+          labels = FALSE,
+          include.lowest = TRUE,
+          right = self$right
+        )
+        midpoints <- breaks[-1] - diff(breaks) / 2
+      } else {
+        x_binned  <- 1L
+        midpoints <- 0.5
+      }
 
       if (!is.null(self$palette.cache)) {
         pal <- self$palette.cache
       } else {
-        pal <- self$palette(breaks[-1] - diff(breaks) / 2)
+        pal <- self$palette(midpoints)
         self$palette.cache <- pal
       }
 
@@ -1075,10 +1081,13 @@ ScaleBinned <- ggproto("ScaleBinned", Scale,
       # Ensure terminal bins are same width if limits not set
       if (is.null(self$limits)) {
         # Remove calculated breaks if they coincide with limits
-        breaks <- setdiff(breaks, limits)
+        breaks <- breaks[!breaks %in% limits]
         nbreaks <- length(breaks)
         if (nbreaks >= 2) {
-          new_limits <- c(2 * breaks[1] - breaks[2], 2 * breaks[nbreaks] - breaks[nbreaks - 1])
+          new_limits <- c(
+            breaks[1] + (breaks[1] - breaks[2]),
+            breaks[nbreaks] + (breaks[nbreaks] - breaks[nbreaks - 1])
+          )
           if (breaks[nbreaks] > limits[2]) {
             new_limits[2] <- breaks[nbreaks]
             breaks <- breaks[-nbreaks]

tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg

@@ -4,3 +4,39 @@ test_that("binned scales only support continuous data", {
   p <- ggplot(mtcars) + geom_point(aes(disp, mpg, colour = as.character(gear))) + scale_color_binned()
   expect_snapshot_error(ggplot_build(p))
 })
+
+test_that('binned scales can calculate breaks on dates', {
+
+  data <- seq(as.Date("2000-01-01"), as.Date("2020-01-01"), length.out = 100)
+
+  scale <- scale_x_binned(trans = "date")
+  scale$train(scale$transform(data))
+  breaks <- scale$trans$inverse(scale$get_breaks())
+
+  expect_s3_class(breaks, "Date")
+  expect_equal(
+    unname(breaks),
+    as.Date(paste0(seq(2002, 2018, by = 2), "-01-01"))
+  )
+})
+
+test_that('binned scales can calculate breaks on date-times', {
+  data <- seq(
+    strptime("2000-01-01", "%Y-%m-%d"),
+    strptime("2020-01-01", "%Y-%m-%d"),
+    length.out = 100
+  )
+
+  scale <- scale_x_binned(trans = "time")
+  scale$train(scale$transform(data))
+  breaks <- scale$trans$inverse(scale$get_breaks())
+
+  expect_s3_class(breaks, "POSIXct")
+  expect_equal(
+    unname(unclass(breaks)),
+    unclass(as.POSIXct(strptime(
+      paste0(seq(2002, 2018, by = 2), "-01-01"),
+      "%Y-%m-%d"
+    )))
+  )
+})