1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
#' Bin and summarise in 2d (rectangle & hexagons)
#'
#' `stat_summary_2d()` is a 2d variation of [stat_summary()].
#' `stat_summary_hex()` is a hexagonal variation of
#' [stat_summary_2d()]. The data are divided into bins defined
#' by `x` and `y`, and then the values of `z` in each cell is
#' are summarised with `fun`.
#'
#' @section Aesthetics:
#' - `x`: horizontal position
#' - `y`: vertical position
#' - `z`: value passed to the summary function
#' @section Computed variables:
#' \describe{
#' \item{x,y}{Location}
#' \item{value}{Value of summary statistic.}
#' }
#' @seealso [stat_summary_hex()] for hexagonal summarization.
#' [stat_bin2d()] for the binning options.
#' @inheritParams layer
#' @inheritParams geom_point
#' @inheritParams stat_bin_2d
#' @param drop drop if the output of `fun` is `NA`.
#' @param fun function for summary.
#' @param fun.args A list of extra arguments to pass to `fun`
#' @export
#' @examples
#' d <- ggplot(diamonds, aes(carat, depth, z = price))
#' 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))
#' }
stat_summary_2d <- function(mapping = NULL, data = NULL,
geom = "tile", position = "identity",
...,
bins = 30,
binwidth = NULL,
drop = TRUE,
fun = "mean",
fun.args = list(),
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = StatSummary2d,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
bins = bins,
binwidth = binwidth,
drop = drop,
fun = fun,
fun.args = fun.args,
na.rm = na.rm,
...
)
)
}
#' @export
#' @rdname stat_summary_2d
#' @usage NULL
stat_summary2d <- function(...) {
message("Please use stat_summary_2d() instead")
stat_summary_2d(...)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSummary2d <- ggproto("StatSummary2d", Stat,
default_aes = aes(fill = after_stat(value)),
required_aes = c("x", "y", "z"),
compute_group = function(data, scales, binwidth = NULL, bins = 30,
breaks = NULL, origin = NULL, drop = TRUE,
fun = "mean", fun.args = list()) {
origin <- dual_param(origin, list(NULL, NULL))
binwidth <- dual_param(binwidth, list(NULL, NULL))
breaks <- dual_param(breaks, list(NULL, NULL))
bins <- dual_param(bins, list(x = 30, y = 30))
xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x)
ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y)
xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE)
ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE)
fun <- as_function(fun)
f <- function(x) {
do.call(fun, c(list(quote(x)), fun.args))
}
out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop)
xdim <- bin_loc(xbreaks, out$xbin)
out$x <- xdim$mid
out$width <- xdim$length
ydim <- bin_loc(ybreaks, out$ybin)
out$y <- ydim$mid
out$height <- ydim$length
out
}
)
# Adaptation of tapply that returns a data frame instead of a matrix
tapply_df <- function(x, index, fun, ..., drop = TRUE) {
labels <- lapply(index, ulevels)
out <- expand.grid(labels, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
grps <- split(x, index)
names(grps) <- NULL
out$value <- unlist(lapply(grps, fun, ...))
if (drop) {
n <- vapply(grps, length, integer(1))
out <- out[n > 0, , drop = FALSE]
}
out
}
|
