From 436f3c582983341ff080d8fbaba097a0b65b8b74 Mon Sep 17 00:00:00 2001 From: David Kahle Date: Mon, 14 Oct 2019 15:25:57 -0500 Subject: [PATCH 1/4] Closes #3568 --- NEWS.md | 3 ++ R/stat-summary-2d.r | 3 ++ R/stat-summary-bin.R | 9 +++- R/stat-summary-hex.r | 1 + man/stat_summary_2d.Rd | 2 + tests/testthat/test-stat-summary.R | 84 ++++++++++++++++++++++++++++++ 6 files changed, 100 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-stat-summary.R diff --git a/NEWS.md b/NEWS.md index a6daad8503..8122c66353 100644 --- a/NEWS.md +++ b/NEWS.md @@ -84,6 +84,9 @@ * Increase the default `nbin` of `guide_colourbar()` to place the ticks more precisely (#3508, @yutannihilation). +* rlang-style lambda functions are now supported by `stat_summary()` and related + functions (#3568, @dkahle). + # ggplot2 3.2.1 This is a patch release fixing a few regressions introduced in 3.2.0 as well as diff --git a/R/stat-summary-2d.r b/R/stat-summary-2d.r index 7c26939bd5..3f279ef798 100644 --- a/R/stat-summary-2d.r +++ b/R/stat-summary-2d.r @@ -30,11 +30,13 @@ #' #' # Specifying function #' d + stat_summary_2d(fun = function(x) sum(x^2)) +#' d + stat_summary_2d(fun = ~ sum(.x^2)) #' d + stat_summary_2d(fun = var) #' d + stat_summary_2d(fun = "quantile", fun.args = list(probs = 0.1)) #' #' if (requireNamespace("hexbin")) { #' d + stat_summary_hex() +#' d + stat_summary_hex(fun = ~ sum(.x^2)) #' } stat_summary_2d <- function(mapping = NULL, data = NULL, geom = "tile", position = "identity", @@ -98,6 +100,7 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) + if (is.formula(fun)) fun <- rlang::as_function(fun) f <- function(x) { do.call(fun, c(list(quote(x)), fun.args)) } diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index 811f598faa..4c97d22ea1 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -96,7 +96,11 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { if (!is.null(fun.data)) { # Function that takes complete data frame as input - fun.data <- match.fun(fun.data) + if (is.formula(fun.data)) { + fun.data <- rlang::as_function(fun.data) + } else { + fun.data <- match.fun(fun.data) + } function(df) { do.call(fun.data, c(list(quote(df$y)), fun.args)) } @@ -105,6 +109,7 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { call_f <- function(fun, x) { if (is.null(fun)) return(NA_real_) + if (is.formula(fun)) fun <- rlang::as_function(fun) do.call(fun, c(list(quote(x)), fun.args)) } @@ -116,7 +121,7 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { )) } } else { - message("No summary function supplied, defaulting to `mean_se()") + message("No summary function supplied, defaulting to `mean_se()`") function(df) { mean_se(df$y) } diff --git a/R/stat-summary-hex.r b/R/stat-summary-hex.r index 205cf55d7a..588a122fba 100644 --- a/R/stat-summary-hex.r +++ b/R/stat-summary-hex.r @@ -46,6 +46,7 @@ StatSummaryHex <- ggproto("StatSummaryHex", Stat, try_require("hexbin", "stat_summary_hex") binwidth <- binwidth %||% hex_binwidth(bins, scales) + if (is.formula(fun)) fun <- rlang::as_function(fun) hexBinSummarise(data$x, data$y, data$z, binwidth, fun = fun, fun.args = fun.args, drop = drop) } diff --git a/man/stat_summary_2d.Rd b/man/stat_summary_2d.Rd index 51a90038c9..25247010f1 100644 --- a/man/stat_summary_2d.Rd +++ b/man/stat_summary_2d.Rd @@ -103,11 +103,13 @@ d + stat_summary_2d() # Specifying function d + stat_summary_2d(fun = function(x) sum(x^2)) +d + stat_summary_2d(fun = ~ sum(.x^2)) d + stat_summary_2d(fun = var) d + stat_summary_2d(fun = "quantile", fun.args = list(probs = 0.1)) if (requireNamespace("hexbin")) { d + stat_summary_hex() +d + stat_summary_hex(fun = ~ sum(.x^2)) } } \seealso{ diff --git a/tests/testthat/test-stat-summary.R b/tests/testthat/test-stat-summary.R new file mode 100644 index 0000000000..1c4b29a166 --- /dev/null +++ b/tests/testthat/test-stat-summary.R @@ -0,0 +1,84 @@ +context("stat_summary") + +test_that("stat_summary(_bin) work with lambda expressions", { + # note: stat_summary and stat_summary_bin both use + # make_summary_fun, so this tests both + + dat <- data_frame( + x = c(1, 1, 2, 2, 3, 3), + y = c(0, 2, 1, 3, 2, 4) + ) + + p1 <- ggplot(dat, aes(x, y)) + + stat_summary(fun.data = mean_se) + + + # test fun.data + p2 <- ggplot(dat, aes(x, y)) + + stat_summary(fun.data = ~ { + mean <- mean(.x) + se <- sqrt(stats::var(.x) / length(.x)) + data_frame(y = mean, ymin = mean - se, ymax = mean + se) + }) + + expect_equal( + layer_data(p1), + layer_data(p2) + ) + + + # fun, fun.min, fun.max + p3 <- ggplot(dat, aes(x, y)) + + stat_summary( + fun = ~ mean(.x), + fun.min = ~ mean(.x) - sqrt(stats::var(.x) / length(.x)), + fun.max = ~ mean(.x) + sqrt(stats::var(.x) / length(.x)) + ) + + expect_equal( + layer_data(p1), + layer_data(p3) + ) + +}) + + + + +test_that("stat_summary_(2d|hex) work with lambda expressions", { + + dat <- data_frame( + x = c(0, 0, 0, 0, 1, 1, 1, 1), + y = c(0, 0, 1, 1, 0, 0, 1, 1), + z = c(1, 1, 2, 2, 2, 2, 3, 3) + ) + + + # stat_summary_2d + p1 <- ggplot(dat, aes(x, y, z = z)) + + stat_summary_2d(fun = function(x) mean(x)) + + p2 <- ggplot(dat, aes(x, y, z = z)) + + stat_summary_2d(fun = ~ mean(.x)) + + expect_equal( + layer_data(p1), + layer_data(p2) + ) + + + + # stat_summary_hex + # this plot is a bit funky, but easy to reason through + p1 <- ggplot(dat, aes(x, y, z = z)) + + stat_summary_hex(fun = function(x) mean(x)) + + p2 <- ggplot(dat, aes(x, y, z = z)) + + stat_summary_hex(fun = ~ mean(.x)) + + expect_equal( + layer_data(p1), + layer_data(p2) + ) + +}) From 3142adba7951caa5034c6bd93d941c13453a79f5 Mon Sep 17 00:00:00 2001 From: David Kahle Date: Sun, 15 Dec 2019 10:00:17 -0600 Subject: [PATCH 2/4] remove rlang:: references, simplify fun.data logic --- R/stat-summary-2d.r | 2 +- R/stat-summary-bin.R | 8 ++------ R/stat-summary-hex.r | 2 +- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/R/stat-summary-2d.r b/R/stat-summary-2d.r index 3f279ef798..3924acddae 100644 --- a/R/stat-summary-2d.r +++ b/R/stat-summary-2d.r @@ -100,7 +100,7 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) - if (is.formula(fun)) fun <- rlang::as_function(fun) + if (is.formula(fun)) fun <- as_function(fun) f <- function(x) { do.call(fun, c(list(quote(x)), fun.args)) } diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index 4c97d22ea1..a00404872d 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -96,11 +96,7 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { if (!is.null(fun.data)) { # Function that takes complete data frame as input - if (is.formula(fun.data)) { - fun.data <- rlang::as_function(fun.data) - } else { - fun.data <- match.fun(fun.data) - } + fun.data <- as_function(fun.data) function(df) { do.call(fun.data, c(list(quote(df$y)), fun.args)) } @@ -109,7 +105,7 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { call_f <- function(fun, x) { if (is.null(fun)) return(NA_real_) - if (is.formula(fun)) fun <- rlang::as_function(fun) + if (is.formula(fun)) fun <- as_function(fun) do.call(fun, c(list(quote(x)), fun.args)) } diff --git a/R/stat-summary-hex.r b/R/stat-summary-hex.r index 588a122fba..08b63d7245 100644 --- a/R/stat-summary-hex.r +++ b/R/stat-summary-hex.r @@ -46,7 +46,7 @@ StatSummaryHex <- ggproto("StatSummaryHex", Stat, try_require("hexbin", "stat_summary_hex") binwidth <- binwidth %||% hex_binwidth(bins, scales) - if (is.formula(fun)) fun <- rlang::as_function(fun) + if (is.formula(fun)) fun <- as_function(fun) hexBinSummarise(data$x, data$y, data$z, binwidth, fun = fun, fun.args = fun.args, drop = drop) } From 86501a3932ac37293f19c49aa1f5a31a05bc841b Mon Sep 17 00:00:00 2001 From: David Kahle Date: Mon, 16 Dec 2019 08:52:39 -0600 Subject: [PATCH 3/4] remove predicate condition for using as_function() in stat_summary_*() functions --- R/stat-summary-2d.r | 2 +- R/stat-summary-bin.R | 2 +- R/stat-summary-hex.r | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/stat-summary-2d.r b/R/stat-summary-2d.r index 3924acddae..7d7a54ead2 100644 --- a/R/stat-summary-2d.r +++ b/R/stat-summary-2d.r @@ -100,7 +100,7 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) - if (is.formula(fun)) fun <- as_function(fun) + fun <- as_function(fun) f <- function(x) { do.call(fun, c(list(quote(x)), fun.args)) } diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index a00404872d..98a13a3346 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -105,7 +105,7 @@ make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) { call_f <- function(fun, x) { if (is.null(fun)) return(NA_real_) - if (is.formula(fun)) fun <- as_function(fun) + fun <- as_function(fun) do.call(fun, c(list(quote(x)), fun.args)) } diff --git a/R/stat-summary-hex.r b/R/stat-summary-hex.r index 08b63d7245..36b69844c4 100644 --- a/R/stat-summary-hex.r +++ b/R/stat-summary-hex.r @@ -46,7 +46,7 @@ StatSummaryHex <- ggproto("StatSummaryHex", Stat, try_require("hexbin", "stat_summary_hex") binwidth <- binwidth %||% hex_binwidth(bins, scales) - if (is.formula(fun)) fun <- as_function(fun) + fun <- as_function(fun) hexBinSummarise(data$x, data$y, data$z, binwidth, fun = fun, fun.args = fun.args, drop = drop) } From 213e0d969c881ba00d000d980b4bf0b76574a115 Mon Sep 17 00:00:00 2001 From: David Kahle Date: Mon, 16 Dec 2019 08:53:15 -0600 Subject: [PATCH 4/4] insert comment in updated news file --- NEWS.md | 33 +++++++++++++++++++++++++++++---- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8122c66353..b2d379d753 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,16 @@ # ggplot2 (development version) +* ggplot2 no longer depends on reshape2, which means that it no longer + (recursively) needs plyr, stringr, or stringi packages. + +* `geom_sf()` now determines the legend type automatically (@microly, #3646). + +* `scale_x_continuous()` and `scale_y_continuous()` gains an `n.breaks` argument + guiding the number of automatic generated breaks (@thomasp85, #3102) + +* `geom_sf()` now removes rows that can't be plotted due to `NA` aesthetics + (#3546, @thomasp85) + * A new scale type has been added, that allows binning of aesthetics at the scale level. It has versions for both position and non-position aesthetics and comes with two new guides (`guide_bins` and `guide_coloursteps`) (@thomasp85, #3096) @@ -14,10 +25,18 @@ * `Geom` now gains a `setup_params()` method in line with the other ggproto classes (@thomasp85, #3509) +* Themes can now modify the theme element tree, via the + `element_tree` argument. This allows extension packages to add functionality that + alters the element tree (@clauswilke, #2540). + * `element_text()` now issues a warning when vectorized arguments are provided, as in `colour = c("red", "green", "blue")`. Such use is discouraged and not officially supported (@clauswilke, #3492). +* Addition of partial themes to plots has been made more predictable; + stepwise addition of individual partial themes is now equivalent to + addition of multple theme elements at once (@clauswilke, #3039). + * stacking text when calculating the labels and the y axis with `stat_summary()` now works (@ikosmidis, #2709) @@ -78,14 +97,20 @@ * `stat_density2d()` can now take an `adjust` parameter to scale the default bandwidth. (#2860, @haleyjeppson) -* `geom_sf()` now removes rows that contain missing `shape`/`size`/`colour` (#3483, @yutannihilation) - * Fix a bug when `show.legend` is a named logical vector (#3461, @yutannihilation). * Increase the default `nbin` of `guide_colourbar()` to place the ticks more precisely (#3508, @yutannihilation). -* rlang-style lambda functions are now supported by `stat_summary()` and related - functions (#3568, @dkahle). +* `geom_sf()` now applies alpha to linestring geometries (#3589, @yutannihilation). + +* `manual_scale()` now matches `values` with the order of `breaks` whenever + `values` is an unnamed vector. Previously, unnamed `values` would match with + the limits of the scale and ignore the order of any `breaks` provided. Note + that this may change the appearance of plots that previously relied on the + unordered behaviour (#2429, @idno0001). + +* `stat_summary()` and related functions now support rlang-style lambda functions + (#3568, @dkahle). # ggplot2 3.2.1