From 02827cac8f694e0625a8406255ba3385b25e3190 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 16 Nov 2021 14:45:35 +0100 Subject: [PATCH 1/4] Pass on binwidth and height to geom --- NEWS.md | 3 +++ R/geom-hex.r | 26 ++++++++++++++++++++++---- R/hexbin.R | 2 ++ 3 files changed, 27 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 5163888679..c0aac04d49 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 (development version) +* `geom_hex()` will now use the binwidth from `stat_bin_hex()` if present, + instead of deriving it (@thomasp85, #4580) + * Setting `stroke` to `NA` in `geom_point()` will no longer impair the sizing of the points (@thomasp85, #4624) diff --git a/R/geom-hex.r b/R/geom-hex.r index 2e18b221e9..df9934ecc4 100644 --- a/R/geom-hex.r +++ b/R/geom-hex.r @@ -56,13 +56,31 @@ geom_hex <- function(mapping = NULL, data = NULL, GeomHex <- ggproto("GeomHex", Geom, draw_group = function(data, panel_params, coord, lineend = "butt", linejoin = "mitre", linemitre = 10) { + if (empty(data)) { + return(zeroGrob()) + } if (!inherits(coord, "CoordCartesian")) { abort("geom_hex() only works with Cartesian coordinates") } + # Extract binwidth and height from data if possible + if (!is.null(data$width)) { + data$xend <- data$x + data$width + } + if (!is.null(data$height)) { + data$yend <- data$y + data$height + } coords <- coord$transform(data, panel_params) + + binwidth <- c(NA, NA) + if (!is.null(data$width)) { + binwidth[1] <- coords$xend[1] - coords$x[1] + } + if (!is.null(data$height)) { + binwidth[2] <- coords$yend[1] - coords$y[1] + } ggname("geom_hex", hexGrob( - coords$x, coords$y, + coords$x, coords$y, binwidth, gp = gpar( col = coords$colour, fill = alpha(coords$fill, coords$alpha), @@ -97,11 +115,11 @@ GeomHex <- ggproto("GeomHex", Geom, # @param size vector of hex sizes # @param gp graphical parameters # @keyword internal -hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) { +hexGrob <- function(x, y, binwidth, size = rep(1, length(x)), gp = gpar()) { if (length(y) != length(x)) abort("`x` and `y` must have the same length") - dx <- resolution(x, FALSE) - dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15 + dx <- if (is.na(binwidth[1])) resolution(x, FALSE) else binwidth[1]/2 + dy <- if (is.na(binwidth[2])) resolution(y, FALSE) / sqrt(3) / 2 * 1.15 else binwidth[2]/ sqrt(3) / 2 hexC <- hexbin::hexcoords(dx, dy, n = 1) diff --git a/R/hexbin.R b/R/hexbin.R index 6d6e38e5fd..296f8f2cce 100644 --- a/R/hexbin.R +++ b/R/hexbin.R @@ -36,6 +36,8 @@ hexBinSummarise <- function(x, y, z, binwidth, fun = mean, fun.args = list(), dr # Convert to data frame out <- new_data_frame(hexbin::hcell2xy(hb)) out$value <- as.vector(value) + out$width <- binwidth[1] + out$height <- binwidth[2] if (drop) out <- stats::na.omit(out) out From 478001e3160d7c97d34cc5c6e10d4ee1d7d810e3 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Tue, 16 Nov 2021 14:56:38 +0100 Subject: [PATCH 2/4] add visual test --- ...e-hex-bin-with-width-and-height-of-0-1.svg | 64 +++++++++++++++++++ tests/testthat/test-geom-hex.R | 8 +++ 2 files changed, 72 insertions(+) create mode 100644 tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg diff --git a/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg b/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg new file mode 100644 index 0000000000..ec51b6ab15 --- /dev/null +++ b/tests/testthat/_snaps/geom-hex/single-hex-bin-with-width-and-height-of-0-1.svg @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 + + + + + + + + + + +-1.0 +-0.5 +0.0 +0.5 +1.0 +x +y + + +1 +count + + +single hex bin with width and height of 0.1 + + diff --git a/tests/testthat/test-geom-hex.R b/tests/testthat/test-geom-hex.R index 3cffeb8a66..5c54e44056 100644 --- a/tests/testthat/test-geom-hex.R +++ b/tests/testthat/test-geom-hex.R @@ -18,3 +18,11 @@ test_that("size and linetype are applied", { expect_equal(gpar$lwd, c(4, 4) * .pt, tolerance = 1e-7) expect_equal(gpar$lty, c(2, 2), tolerance = 1e-7) }) + +test_that("bin size are picked up from stat", { + expect_doppelganger("single hex bin with width and height of 0.1", + ggplot(data.frame(x = 0, y = 0)) + + geom_hex(aes(x = x, y = y), binwidth = c(0.1, 0.1)) + + coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) + ) +}) From 538857a86b9895f0c71f3711340549e5e74c23fa Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 24 Nov 2021 11:27:00 +0100 Subject: [PATCH 3/4] refactor geom_hex to work on non-linear coords --- NEWS.md | 2 + R/geom-hex.r | 45 +++-- .../hex-bin-plot-in-polar-coordinates.svg | 183 ++++++++++++++++++ .../hex-bin-plot-with-sqrt-transformed-y.svg | 181 +++++++++++++++++ tests/testthat/test-geom-hex.R | 15 +- 5 files changed, 405 insertions(+), 21 deletions(-) create mode 100644 tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg create mode 100644 tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg diff --git a/NEWS.md b/NEWS.md index c0aac04d49..0eb4ba803f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ * `geom_hex()` will now use the binwidth from `stat_bin_hex()` if present, instead of deriving it (@thomasp85, #4580) + +* `geom_hex()` now works on non-linear coordinate systems (@thomasp85) * Setting `stroke` to `NA` in `geom_point()` will no longer impair the sizing of the points (@thomasp85, #4624) diff --git a/R/geom-hex.r b/R/geom-hex.r index df9934ecc4..cc0789abea 100644 --- a/R/geom-hex.r +++ b/R/geom-hex.r @@ -59,28 +59,31 @@ GeomHex <- ggproto("GeomHex", Geom, if (empty(data)) { return(zeroGrob()) } - if (!inherits(coord, "CoordCartesian")) { - abort("geom_hex() only works with Cartesian coordinates") - } - # Extract binwidth and height from data if possible + + # Get hex sizes if (!is.null(data$width)) { - data$xend <- data$x + data$width + dx <- data$width[1] / 2 + } else { + dx <- resolution(data$x, FALSE) } if (!is.null(data$height)) { - data$yend <- data$y + data$height + dy <- data$height[1] / sqrt(3) / 2 + } else { + dy <- resolution(data$y, FALSE) / sqrt(3) / 2 * 1.15 } + hexC <- hexbin::hexcoords(dx, dy, n = 1) + + n <- nrow(data) + + data <- data[rep(seq_len(n), each = 6), ] + data$x <- rep.int(hexC$x, n) + data$x + data$y <- rep.int(hexC$y, n) + data$y + coords <- coord$transform(data, panel_params) - binwidth <- c(NA, NA) - if (!is.null(data$width)) { - binwidth[1] <- coords$xend[1] - coords$x[1] - } - if (!is.null(data$height)) { - binwidth[2] <- coords$yend[1] - coords$y[1] - } - ggname("geom_hex", hexGrob( - coords$x, coords$y, binwidth, + ggname("geom_hex", polygonGrob( + coords$x, coords$y, gp = gpar( col = coords$colour, fill = alpha(coords$fill, coords$alpha), @@ -89,7 +92,9 @@ GeomHex <- ggproto("GeomHex", Geom, lineend = lineend, linejoin = linejoin, linemitre = linemitre - ) + ), + default.units = "native", + id.lengths = rep.int(6, n) )) }, @@ -115,11 +120,13 @@ GeomHex <- ggproto("GeomHex", Geom, # @param size vector of hex sizes # @param gp graphical parameters # @keyword internal -hexGrob <- function(x, y, binwidth, size = rep(1, length(x)), gp = gpar()) { +# +# THIS IS NO LONGER USED BUT LEFT IF CODE SOMEWHERE ELSE RELIES ON IT +hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) { if (length(y) != length(x)) abort("`x` and `y` must have the same length") - dx <- if (is.na(binwidth[1])) resolution(x, FALSE) else binwidth[1]/2 - dy <- if (is.na(binwidth[2])) resolution(y, FALSE) / sqrt(3) / 2 * 1.15 else binwidth[2]/ sqrt(3) / 2 + dx <- resolution(x, FALSE) + dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15 hexC <- hexbin::hexcoords(dx, dy, n = 1) diff --git a/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg b/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg new file mode 100644 index 0000000000..34bc427bd8 --- /dev/null +++ b/tests/testthat/_snaps/geom-hex/hex-bin-plot-in-polar-coordinates.svg @@ -0,0 +1,183 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 +3 +4 +5 +6 + + + +20 +30 +40 + + + +displ +hwy + + +2.5 +5.0 +7.5 +10.0 +count + + + + + + + + +hex bin plot in polar coordinates + + diff --git a/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg b/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg new file mode 100644 index 0000000000..82486696e1 --- /dev/null +++ b/tests/testthat/_snaps/geom-hex/hex-bin-plot-with-sqrt-transformed-y.svg @@ -0,0 +1,181 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +20 +30 +40 + + + + + + + + + +2 +3 +4 +5 +6 +7 +displ +hwy + + +2.5 +5.0 +7.5 +10.0 +count + + + + + + + + +hex bin plot with sqrt-transformed y + + diff --git a/tests/testthat/test-geom-hex.R b/tests/testthat/test-geom-hex.R index 5c54e44056..82465e2183 100644 --- a/tests/testthat/test-geom-hex.R +++ b/tests/testthat/test-geom-hex.R @@ -15,8 +15,8 @@ test_that("size and linetype are applied", { geom_hex(color = "red", size = 4, linetype = 2) gpar <- layer_grob(plot)[[1]]$children[[1]]$gp - expect_equal(gpar$lwd, c(4, 4) * .pt, tolerance = 1e-7) - expect_equal(gpar$lty, c(2, 2), tolerance = 1e-7) + expect_equal(gpar$lwd, rep(4, 12) * .pt, tolerance = 1e-7) + expect_equal(gpar$lty, rep(2, 12), tolerance = 1e-7) }) test_that("bin size are picked up from stat", { @@ -26,3 +26,14 @@ test_that("bin size are picked up from stat", { coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) ) }) + +test_that("geom_hex works in non-linear coordinate systems", { + p <- ggplot(mpg, aes(displ, hwy)) + geom_hex() + + expect_doppelganger("hex bin plot with sqrt-transformed y", + p + coord_trans(y = "sqrt") + ) + expect_doppelganger("hex bin plot in polar coordinates", + p + coord_polar() + ) +}) From 078fc2255c66418de31c1d78d541d6a7f661ccc2 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Mon, 6 Dec 2021 10:39:36 +0100 Subject: [PATCH 4/4] add comment on scaling --- R/geom-hex.r | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/geom-hex.r b/R/geom-hex.r index cc0789abea..e28e1cbe74 100644 --- a/R/geom-hex.r +++ b/R/geom-hex.r @@ -66,6 +66,9 @@ GeomHex <- ggproto("GeomHex", Geom, } else { dx <- resolution(data$x, FALSE) } + # Adjust for difference in width and height of regular hexagon. 1.15 adjusts + # for the effect of the overlapping range in y-direction on the resolution + # calculation if (!is.null(data$height)) { dy <- data$height[1] / sqrt(3) / 2 } else {