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
|
#' @rdname stat_summary
#' @inheritParams stat_bin
#' @export
stat_summary_bin <- function(mapping = NULL, data = NULL,
geom = "pointrange", position = "identity",
...,
fun.data = NULL,
fun = NULL,
fun.max = NULL,
fun.min = NULL,
fun.args = list(),
bins = 30,
binwidth = NULL,
breaks = NULL,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE,
fun.y, fun.ymin, fun.ymax) {
if (!missing(fun.y)) {
warn("`fun.y` is deprecated. Use `fun` instead.")
fun = fun %||% fun.y
}
if (!missing(fun.ymin)) {
warn("`fun.ymin` is deprecated. Use `fun.min` instead.")
fun.min = fun.min %||% fun.ymin
}
if (!missing(fun.ymax)) {
warn("`fun.ymax` is deprecated. Use `fun.max` instead.")
fun.max = fun.max %||% fun.ymax
}
layer(
data = data,
mapping = mapping,
stat = StatSummaryBin,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
fun.data = fun.data,
fun = fun,
fun.max = fun.max,
fun.min = fun.min,
fun.args = fun.args,
bins = bins,
binwidth = binwidth,
breaks = breaks,
na.rm = na.rm,
orientation = orientation,
...
)
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSummaryBin <- ggproto("StatSummaryBin", Stat,
required_aes = c("x", "y"),
extra_params = c("na.rm", "orientation"),
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
compute_group = function(data, scales, fun.data = NULL, fun = NULL,
fun.max = NULL, fun.min = NULL, fun.args = list(),
bins = 30, binwidth = NULL, breaks = NULL,
origin = NULL, right = FALSE, na.rm = FALSE,
flipped_aes = FALSE) {
data <- flip_data(data, flipped_aes)
fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args)
x <- flipped_names(flipped_aes)$x
breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, right = right)
data$bin <- cut(data$x, breaks, include.lowest = TRUE, labels = FALSE)
out <- dapply(data, "bin", fun)
locs <- bin_loc(breaks, out$bin)
out$x <- locs$mid
out$width <- if (scales[[x]]$is_discrete()) 0.9 else locs$length
out$flipped_aes <- flipped_aes
flip_data(out, flipped_aes)
}
)
make_summary_fun <- function(fun.data, fun, fun.max, fun.min, fun.args) {
force(fun.data)
force(fun)
force(fun.max)
force(fun.min)
force(fun.args)
if (!is.null(fun.data)) {
# Function that takes complete data frame as input
fun.data <- as_function(fun.data)
function(df) {
do.call(fun.data, c(list(quote(df$y)), fun.args))
}
} else if (!is.null(fun) || !is.null(fun.max) || !is.null(fun.min)) {
# Three functions that take vectors as inputs
call_f <- function(fun, x) {
if (is.null(fun)) return(NA_real_)
fun <- as_function(fun)
do.call(fun, c(list(quote(x)), fun.args))
}
function(df, ...) {
new_data_frame(list(
ymin = call_f(fun.min, df$y),
y = call_f(fun, df$y),
ymax = call_f(fun.max, df$y)
))
}
} else {
message("No summary function supplied, defaulting to `mean_se()`")
function(df) {
mean_se(df$y)
}
}
}
|
