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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
#' @export
#' @rdname geom_density_2d
#' @param contour If `TRUE`, contour the results of the 2d density
#' estimation.
#' @param contour_var Character string identifying the variable to contour
#' by. Can be one of `"density"`, `"ndensity"`, or `"count"`. See the section
#' on computed variables for details.
#' @inheritDotParams geom_contour bins binwidth breaks
#' @param n Number of grid points in each direction.
#' @param h Bandwidth (vector of length two). If `NULL`, estimated
#' using [MASS::bandwidth.nrd()].
#' @param adjust A multiplicative bandwidth adjustment to be used if 'h' is
#' 'NULL'. This makes it possible to adjust the bandwidth while still
#' using the a bandwidth estimator. For example, `adjust = 1/2` means
#' use half of the default bandwidth.
#' @eval rd_computed_vars(
#' .details = "`stat_density_2d()` and `stat_density_2d_filled()` compute
#' different variables depending on whether contouring is turned on or off.
#' With contouring off (`contour = FALSE`), both stats behave the same, and
#' the following variables are provided:",
#' density = "The density estimate.",
#' ndensity = "Density estimate, scaled to a maximum of 1.",
#' count = "Density estimate * number of observations in group.",
#' n = "Number of observations in each group."
#' )
#'
#' @section Computed variables:
#' With contouring on (`contour = TRUE`), either [stat_contour()] or
#' [stat_contour_filled()] (for contour lines or contour bands,
#' respectively) is run after the density estimate has been obtained,
#' and the computed variables are determined by these stats.
#' Contours are calculated for one of the three types of density estimates
#' obtained before contouring, `density`, `ndensity`, and `count`. Which
#' of those should be used is determined by the `contour_var` parameter.
#'
#' @section Dropped variables:
#' \describe{
#' \item{`z`}{After density estimation, the z values of individual data points are no longer available.}
#' }
#'
#' If contouring is enabled, then similarly `density`, `ndensity`, and `count`
#' are no longer available after the contouring pass.
#'
stat_density_2d <- function(mapping = NULL, data = NULL,
geom = "density_2d", position = "identity",
...,
contour = TRUE,
contour_var = "density",
n = 100,
h = NULL,
adjust = c(1, 1),
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = StatDensity2d,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
na.rm = na.rm,
contour = contour,
contour_var = contour_var,
n = n,
h = h,
adjust = adjust,
...
)
)
}
#' @rdname geom_density_2d
#' @usage NULL
#' @export
stat_density2d <- stat_density_2d
#' @rdname geom_density_2d
#' @export
stat_density_2d_filled <- function(mapping = NULL, data = NULL,
geom = "density_2d_filled", position = "identity",
...,
contour = TRUE,
contour_var = "density",
n = 100,
h = NULL,
adjust = c(1, 1),
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = StatDensity2dFilled,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
na.rm = na.rm,
contour = contour,
contour_var = contour_var,
n = n,
h = h,
adjust = adjust,
...
)
)
}
#' @rdname geom_density_2d
#' @usage NULL
#' @export
stat_density2d_filled <- stat_density_2d_filled
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatDensity2d <- ggproto("StatDensity2d", Stat,
default_aes = aes(colour = "#3366FF", size = 0.5),
required_aes = c("x", "y"),
# because of the chained calculation in compute_panel(),
# which calls compute_panel() of a different stat, we declare
# dropped aesthetics there
dropped_aes = character(0),
extra_params = c(
"na.rm", "contour", "contour_var",
"bins", "binwidth", "breaks"
),
# when contouring is on, are we returning lines or bands?
contour_type = "lines",
compute_layer = function(self, data, params, layout) {
# first run the regular layer calculation to infer densities
data <- ggproto_parent(Stat, self)$compute_layer(data, params, layout)
# if we're not contouring we're done
if (!isTRUE(params$contour)) return(data)
# set up data and parameters for contouring
contour_var <- params$contour_var %||% "density"
if (!isTRUE(contour_var %in% c("density", "ndensity", "count"))) {
cli::cli_abort(c(
"Invalid value of {.arg contour_var} ({.val {contour_var}})",
"i" = "Supported values are {.val density}, {.val ndensity}, and {.val count}."
))
}
data$z <- data[[contour_var]]
z.range <- range(data$z, na.rm = TRUE, finite = TRUE)
params <- params[intersect(names(params), c("bins", "binwidth", "breaks"))]
params$z.range <- z.range
if (isTRUE(self$contour_type == "bands")) {
contour_stat <- ggproto(NULL, StatContourFilled)
} else { # lines is the default
contour_stat <- ggproto(NULL, StatContour)
}
# update dropped aes
contour_stat$dropped_aes <- c(contour_stat$dropped_aes, "density", "ndensity", "count")
dapply(data, "PANEL", function(data) {
scales <- layout$get_scales(data$PANEL[1])
try_fetch(
inject(contour_stat$compute_panel(data = data, scales = scales, !!!params)),
error = function(cnd) {
cli::cli_warn("Computation failed in {.fn {snake_class(self)}}", parent = cnd)
data_frame0()
}
)
})
},
compute_group = function(data, scales, na.rm = FALSE, h = NULL, adjust = c(1, 1),
n = 100, ...) {
if (is.null(h)) {
h <- c(MASS::bandwidth.nrd(data$x), MASS::bandwidth.nrd(data$y))
h <- h * adjust
}
# calculate density
dens <- MASS::kde2d(
data$x, data$y, h = h, n = n,
lims = c(scales$x$dimension(), scales$y$dimension())
)
# prepare final output data frame
nx <- nrow(data) # number of observations in this group
df <- expand.grid(x = dens$x, y = dens$y)
df$density <- as.vector(dens$z)
df$group <- data$group[1]
df$ndensity <- df$density / max(df$density, na.rm = TRUE)
df$count <- nx * df$density
df$n <- nx
df$level <- 1
df$piece <- 1
df
}
)
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatDensity2dFilled <- ggproto("StatDensity2dFilled", StatDensity2d,
default_aes = aes(colour = NA, fill = after_stat(level)),
contour_type = "bands"
)
|
