WIP: Group summary stat

DESCRIPTION

@@ -262,6 +262,7 @@ Collate:
  'stat-smooth-methods.R'
  'stat-smooth.R'
  'stat-sum.R'
+ 'stat-summarise.R'
  'stat-summary-2d.R'
  'stat-summary-bin.R'
  'stat-summary-hex.R'

NAMESPACE

@@ -274,6 +274,7 @@ export(StatSf)
 export(StatSfCoordinates)
 export(StatSmooth)
 export(StatSum)
+export(StatSummarise)
 export(StatSummary)
 export(StatSummary2d)
 export(StatSummaryBin)
@@ -686,6 +687,7 @@ export(stat_sf_coordinates)
 export(stat_smooth)
 export(stat_spoke)
 export(stat_sum)
+export(stat_summarise)
 export(stat_summary)
 export(stat_summary2d)
 export(stat_summary_2d)

R/stat-summarise.R

@@ -0,0 +1,129 @@
+#' Arbitrary summaries by group
+#'
+#' `stat_summarise()` handles arbitrary summaries by group. Unlike
+#' [`stat_summary()`], it does not automatically summarise by `x`.
+#'
+#' @inheritParams stat_identity
+#' @param fun A function that is given the complete data per group and should
+#' return a data.frame with variables compatible with the layer's `geom`
+#' argument. Defaults to `express_group()` which will evaluate
+#' [data-masked][rlang::args_data_masking] expressions passed to `fun.args`.
+#' @param fun.args Optional additional arguments to pass to `fun`. When
+#' `fun = express_group` (default), can be a list of expressions created by
+#' `vars()`.
+#' @eval rd_aesthetics("stat", "summarise")
+#' @export
+#'
+#' @examples
+#' # Using a helper summary function
+#' my_summary_fun <- function(data) {
+#' data.frame(
+#' x = min(data$x) - 0.5,
+#' xend = max(data$x) + 0.5,
+#' y = mean(data$y)
+#' )
+#' }
+#'
+#' ggplot(mpg, aes(drv, displ)) +
+#' geom_jitter(aes(colour = drv)) +
+#' stat_summarise(
+#' geom = "segment",
+#' fun = my_summary_fun
+#' )
+#'
+#' # Making the same summary using the `exprs` argument
+#' ggplot(mpg, aes(drv, displ)) +
+#' geom_jitter(aes(colour = drv)) +
+#' stat_summarise(
+#' geom = "segment",
+#' fun.args = vars(
+#' # Note: we use `xend` first to not mutate `x` too soon
+#' xend = max(x) + 0.5,
+#' x = min(x) - 0.5,
+#' y = mean(y)
+#' )
+#' )
+#'
+#' # You can use a temporary variable that needn't conform to data.frame columns
+#' # as long as it is removed afterwards
+#' ggplot(mpg, aes(displ, colour = drv)) +
+#' stat_summarise(
+#' geom = "line",
+#' fun.args = vars(
+#' dens = density(x), # non-vector temporary variable
+#' x = dens$x,
+#' y = dens$y,
+#' dens = NULL # deleting the temporary variable
+#' )
+#' )
+stat_summarise <- function(
+ mapping = NULL,
+ data = NULL,
+ geom = "point",
+ position = "identity",
+ ...,
+ fun = express_group,
+ fun.args = list(),
+ na.rm = FALSE,
+ show.legend = NA,
+ inherit.aes = TRUE
+) {
+
+ layer(
+ data = data,
+ mapping = mapping,
+ stat = StatSummarise,
+ geom = geom,
+ position = position,
+ show.legend = show.legend,
+ inherit.aes = inherit.aes,
+ params = list2(
+ na.rm = na.rm,
+ fun = fun,
+ fun.args = fun.args,
+ ...
+ )
+ )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+StatSummarise <- ggproto(
+ "StatSummarise", Stat,
+
+ setup_params = function(data, params) {
+ params$fun <- allow_lambda(params$fun)
+ check_function(params$fun, arg = "fun")
+ if (!is_named2(params$fun.args)) {
+ cli::cli_abort("Every element in {.arg fun.args} must be named.")
+ }
+ if (identical(params$fun, express_group) && length(params$fun.args) > 0) {
+ check_object(
+ params$fun.args, is_quosures, arg = "fun.args",
+ "generated by `vars()`", allow_null = TRUE
+ )
+ }
+ params
+ },
+
+ compute_group = function(data, scales, fun = express_group, fun.args = list()) {
+ inject(fun(data, !!!fun.args))
+ }
+)
+
+express_group <- function(data, ...) {
+ exprs <- list2(...)
+ if (length(exprs) < 1) {
+ return(data)
+ }
+ data <- unclass(data)
+ # We append each evaluated expression to `data`, so that the next expression
+ # can use the result of all previously evaluated expressions
+ nms <- names(exprs)
+ for (i in seq_along(exprs)) {
+ data[[nms[[i]]]] <- eval_tidy(exprs[[i]], data)
+ }
+ data_frame0(!!!data[unique0(names(exprs))])
+}