From 8c18897a638a35c99ec9b5aca0be76a1efa21c93 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 28 May 2024 14:38:39 +0200 Subject: [PATCH 1/5] attempt contour calculation in unrotated space --- R/stat-contour.R | 58 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/R/stat-contour.R b/R/stat-contour.R index 882879430d..c73fdac5d4 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -104,6 +104,9 @@ StatContour <- ggproto("StatContour", Stat, compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL, breaks = NULL, na.rm = FALSE) { + # Undo data rotation + rotation <- estimate_contour_angle(data$x, data$y) + data[c("x", "y")] <- rotate_xy(data$x, data$y, -rotation) breaks <- contour_breaks(z.range, bins, binwidth, breaks) @@ -113,6 +116,8 @@ StatContour <- ggproto("StatContour", Stat, path_df$level <- as.numeric(path_df$level) path_df$nlevel <- rescale_max(path_df$level) + # Re-apply data rotation + path_df[c("x", "y")] <- rotate_xy(path_df$x, path_df$y, rotation) path_df } ) @@ -138,6 +143,11 @@ StatContourFilled <- ggproto("StatContourFilled", Stat, }, compute_group = function(data, scales, z.range, bins = NULL, binwidth = NULL, breaks = NULL, na.rm = FALSE) { + + # Undo data rotation + rotation <- estimate_contour_angle(data$x, data$y) + data[c("x", "y")] <- rotate_xy(data$x, data$y, -rotation) + breaks <- contour_breaks(z.range, bins, binwidth, breaks) isobands <- withr::with_options(list(OutDec = "."), xyz_to_isobands(data, breaks)) @@ -149,6 +159,8 @@ StatContourFilled <- ggproto("StatContourFilled", Stat, path_df$level_high <- breaks[as.numeric(path_df$level) + 1] path_df$level_mid <- 0.5*(path_df$level_low + path_df$level_high) path_df$nlevel <- rescale_max(path_df$level_high) + # Re-apply data rotation + path_df[c("x", "y")] <- rotate_xy(path_df$x, path_df$y, rotation) path_df } @@ -385,3 +397,49 @@ contour_deduplicate <- function(data, check = c("x", "y", "group", "PANEL")) { } data } + +estimate_contour_angle <- function(x, y) { + + # Compute most frequent angle + all_angles <- atan2(diff(y), diff(x)) + freq <- tabulate(match(all_angles, unique(all_angles))) + i <- which.max(freq) + + # If this angle represents less than half of the angles, we probably + # have unordered data, in which case the approach above is invalid + if ((freq[i] / sum(freq)) < 0.5) { + # In such case, try approach with convex hull + hull <- grDevices::chull(x, y) + hull <- c(hull, hull[1]) + # Find largest edge along hull + dx <- diff(x[hull]) + dy <- diff(y[hull]) + i <- which.max(sqrt(dx^2)) + # Take angle of largest edge + angle <- atan2(dy[i], dx[i]) + } else { + angle <- all_angles[i] + } + + # No need to rotate contour data when angle is straight + straight <- abs(angle - c(-1, -0.5, 0, 0.5, 1) * pi) < sqrt(.Machine$double.eps) + if (any(straight)) { + return(0) + } + angle +} + +rotate_xy <- function(x, y, angle) { + # Skip rotation if angle was straight + if (angle == 0) { + return(list(x = x, y = y)) + } + cos <- cos(angle) + sin <- sin(angle) + # Using zapsmall to make `unique0` later recognise values that may have + # rounding errors. + list( + x = zapsmall(cos * x - sin * y, digits = 13), + y = zapsmall(sin * x + cos * y, digits = 13) + ) +} From 9b201238401efa527448ec183c0c7daa5107ef0c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 28 May 2024 14:38:49 +0200 Subject: [PATCH 2/5] add test --- tests/testthat/test-stat-contour.R | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/tests/testthat/test-stat-contour.R b/tests/testthat/test-stat-contour.R index bab39b7b6d..4f8e098da5 100644 --- a/tests/testthat/test-stat-contour.R +++ b/tests/testthat/test-stat-contour.R @@ -100,3 +100,26 @@ test_that("stat_contour() removes duplicated coordinates", { expect_equal(new, df[1:4,], ignore_attr = TRUE) }) +test_that("stat_contour() can infer rotations", { + df <- data_frame0( + x = c(0, 1, 2, 1), + y = c(1, 2, 1, 0), + z = c(1, 1, 2, 2) + ) + + ld <- layer_data( + ggplot(df, aes(x, y, z = z)) + geom_contour(breaks = 1.5) + ) + expect_equal(ld$x, c(1.5, 0.5)) + expect_equal(ld$y, c(1.5, 0.5)) + + # Also for unordered data + df <- df[c(1, 4, 2, 3), ] + + ld <- layer_data( + ggplot(df, aes(x, y, z = z)) + geom_contour(breaks = 1.5) + ) + + expect_equal(ld$x, c(0.5, 1.5)) + expect_equal(ld$y, c(0.5, 1.5)) +}) From 8c39e895c7da2d09de28f0989208aa3d6a88ec6a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 28 May 2024 14:38:58 +0200 Subject: [PATCH 3/5] add news bullet --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index de3e87cee3..fad1d131b1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* `geom_contour()` should be able to recognise a rotated grid of points + (@teunbrand, #4320) * The `arrow.fill` parameter is now applied to more line-based functions: `geom_path()`, `geom_line()`, `geom_step()` `geom_function()`, line geometries in `geom_sf()` and `element_line()`. From b2d4537d2d27cddbbe8b9ed58e25c68a4240b315 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 28 May 2024 14:51:28 +0200 Subject: [PATCH 4/5] fix mistake in calculation --- R/stat-contour.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stat-contour.R b/R/stat-contour.R index c73fdac5d4..9e03171d0a 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -414,7 +414,7 @@ estimate_contour_angle <- function(x, y) { # Find largest edge along hull dx <- diff(x[hull]) dy <- diff(y[hull]) - i <- which.max(sqrt(dx^2)) + i <- which.max(sqrt(dx^2 + dy^2)) # Take angle of largest edge angle <- atan2(dy[i], dx[i]) } else { From fb2e4fe8d06995a46c68af31fed6d1dad50e83ed Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 20 Aug 2024 10:28:58 +0200 Subject: [PATCH 5/5] protect against huge amounts of data --- R/stat-contour.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stat-contour.R b/R/stat-contour.R index 9e03171d0a..0975d37a94 100644 --- a/R/stat-contour.R +++ b/R/stat-contour.R @@ -400,8 +400,8 @@ contour_deduplicate <- function(data, check = c("x", "y", "group", "PANEL")) { estimate_contour_angle <- function(x, y) { - # Compute most frequent angle - all_angles <- atan2(diff(y), diff(x)) + # Compute most frequent angle among first 20 points + all_angles <- atan2(diff(head(y, 20L)), diff(head(x, 20L))) freq <- tabulate(match(all_angles, unique(all_angles))) i <- which.max(freq)