diff --git a/NEWS.md b/NEWS.md index b70816fd1f..ed626079f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -327,6 +327,7 @@ to retrieve the class via constructor functions (@teunbrand). * (internal) The ViewScale class has a `make_fixed_copy()` method to permit copying trained position scales (#3441). +* Improved consistency of curve direction in `geom_curve()` (@teunbrand, #5069) # ggplot2 3.5.1 diff --git a/R/geom-curve.R b/R/geom-curve.R index 23b2e551ed..6d6ec0027d 100644 --- a/R/geom-curve.R +++ b/R/geom-curve.R @@ -55,6 +55,15 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, trans <- coord$transform(data, panel_params) + flip <- flip_curve(trans, coord, panel_params) + if (flip) { + trans <- rename(trans, c(x = "xend", xend = "x", y = "yend", yend = "y")) + if (!is.null(arrow)) { + # Flip end where arrow appears (2 = last, 1 = first, 3 = both) + arrow$ends <- match(arrow$ends, c(2, 1, 3)) + } + } + arrow.fill <- arrow.fill %||% trans$colour curveGrob( @@ -72,3 +81,41 @@ GeomCurve <- ggproto("GeomCurve", GeomSegment, ) } ) + +# Helper function for determining whether curves should swap segment ends to +# keep curvature consistent over transformations +flip_curve <- function(data, coord, params) { + flip <- FALSE + + # Figure implicit flipping transformations in coords + if (inherits(coord, "CoordFlip")) { + flip <- !flip + } else if (inherits(coord, "CoordTrans")) { + if (identical(coord$trans$x$name, "reverse")) { + flip <- !flip + } + if (identical(coord$trans$y$name, "reverse")) { + flip <- !flip + } + } + + # We don't flip when none or both directions are reversed + if ((coord$reverse %||% "none") %in% c("x", "y")) { + flip <- !flip + } + + # Check scales for reverse transforms + # Note that polar coords do not have x/y scales, but these are unsupported + # anyway + fn <- params$x$get_transformation + if (is.function(fn) && identical(fn()$name, "reverse")) { + flip <- !flip + } + + fn <- params$y$get_transformation + if (is.function(fn) && identical(fn()$name, "reverse")) { + flip <- !flip + } + + flip +} diff --git a/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg b/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg new file mode 100644 index 0000000000..0a82d0b2af --- /dev/null +++ b/tests/testthat/_snaps/geom-curve/flipped-geom-curve.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.00 +1.25 +1.50 +1.75 +2.00 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y +flipped geom_curve + + diff --git a/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg b/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg new file mode 100644 index 0000000000..645b025c9d --- /dev/null +++ b/tests/testthat/_snaps/geom-curve/standard-geom-curve.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1.00 +1.25 +1.50 +1.75 +2.00 + + + + + + + + + + +1.0 +1.5 +2.0 +2.5 +3.0 +x +y +standard geom_curve + + diff --git a/tests/testthat/test-geom-curve.R b/tests/testthat/test-geom-curve.R new file mode 100644 index 0000000000..05f959916e --- /dev/null +++ b/tests/testthat/test-geom-curve.R @@ -0,0 +1,11 @@ +test_that("geom_curve flipping works", { + + df <- data.frame(x = c(1, 2), xend = c(2, 3), y = 1, yend = c(2, 1.5)) + + p <- ggplot(df, aes(x, y, xend = xend, yend = yend)) + + geom_curve(arrow = arrow()) + + expect_doppelganger("standard geom_curve", p) + expect_doppelganger("flipped geom_curve", p + scale_y_reverse()) + +})