# Constructor -------------------------------------------------------------
#' Apply function to position coordinates
#'
#' The function xy stat applies a function to the x- and y-coordinates of a
#' layers positions by group. The `stat_centroid()` and
#' `stat_midpoint()` functions are convenience wrappers for calculating
#' centroids and midpoints. `stat_funxy()` by default leaves the data
#' as-is, but can be supplied functions and arguments.
#'
#' @inheritParams ggplot2::stat_identity
#' @param funx,funy A `function` to call on the layer's `x` and
#' `y` positions respectively.
#' @param argx,argy A named `list` containing arguments to the `funx`,
#' and `funy` function calls.
#' @param crop_other A `logical` of length one; whether the other data
#' should be fitted to the length of `x` and `y` (default:
#' `TRUE`). Useful to set to `FALSE` when `funx` or `funy`
#' calculate summaries of length one that need to be recycled.
#'
#' @details This statistic only makes a minimal attempt at ensuring that the
#' results from calling both functions are of equal length. Results of length
#' 1 are recycled to match the longest length result.
#'
#' @return A `StatFunxy` ggproto object, that can be added to a plot.
#' @export
#'
#' @examples
#' p <- ggplot(iris, aes(Sepal.Width, Sepal.Length, colour = Species))
#'
#' # Labelling group midpoints
#' p + geom_point() +
#' stat_midpoint(aes(label = Species, group = Species),
#' geom = "text", colour = "black")
#'
#' # Drawing segments to centroids
#' p + geom_point() +
#' stat_centroid(aes(xend = Sepal.Width, yend = Sepal.Length),
#' geom = "segment", crop_other = FALSE)
#'
#' # Drawing intervals
#' ggplot(iris, aes(Sepal.Width, Sepal.Length, colour = Species)) +
#' geom_point() +
#' stat_funxy(geom = "path",
#' funx = median, funy = quantile,
#' argy = list(probs = c(0.1, 0.9)))
stat_funxy <-
function(mapping = NULL, data = NULL, geom = "point",
position = "identity", ..., funx = force, funy = force,
argx = list(), argy = list(), crop_other = TRUE,
show.legend = NA, inherit.aes = TRUE) {
stopifnot(
"The `funx` argument must be a function." =
is.function(funx),
"The `funy` argument must be a function." =
is.function(funy),
"The `argx` and `argy` arguments must be lists." =
is.list(argx) & is.list(argy),
"The `argx` list must have named elements" =
length(argx) == sum(nzchar(names(argx))),
"The `argy` list must have named elements" =
length(argy) == sum(nzchar(names(argy)))
)
layer(
data = data,
mapping = mapping,
stat = StatFunxy,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
funx = funx, funy = funy,
argx = argx, argy = argy,
crop_other = crop_other,
...
)
)
}
#' @rdname stat_funxy
#' @export
stat_centroid <- function(...,
funx = mean, funy = mean,
argx = list(na.rm = TRUE), argy = list(na.rm = TRUE)) {
stat_funxy(..., funx = funx, funy = funy, argx = argx, argy = argy)
}
#' @rdname stat_funxy
#' @export
stat_midpoint <- function(...,
argx = list(na.rm = TRUE),
argy = list(na.rm = TRUE)) {
fun <- function(x, na.rm = TRUE) {
sum(range(x, na.rm = na.rm), na.rm = na.rm)/2
}
stat_funxy(..., funx = fun, funy = fun, argx = argx, argy = argy)
}
# ggproto -----------------------------------------------------------------
#' @usage NULL
#' @format NULL
#' @export
#' @rdname ggh4x_extensions
StatFunxy <- ggproto(
"StatFunxy", Stat,
required_aes = c("x", "y"),
compute_group = function(data, scales,
funx, funy,
argx, argy,
crop_other = TRUE) {
# Make list for cheaper operations
data <- as.list(data)
# Apply functions
x <- do.call(funx, c(unname(data["x"]), argx))
y <- do.call(funy, c(unname(data["y"]), argy))
# Ensure rest of data is of correct length
other <- setdiff(names(data), c("x", "y"))
size <- seq_len(max(length(x), length(y)))
if (isTRUE(crop_other)) {
other <- lapply(data[other], `[`, i = size)
} else {
other <- data[other]
}
# Combine data
data <- c(other, list(x = x, y = y))
data <- do.call(vec_recycle_common, data)
new_data_frame(data)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.