为此,我撰写了一份新的《章程》。
It takes nbins
, bin_var
, bin_fun
and summary_fun
as arguments, with defaults for all four.
- The default for
nbins
depends on the number of data points.
- The default for
bin_var
is "x". You can also set it to "y". This specifies the variable that is fed to bin_fun
.
bin_fun
is the binning function. By default, it s seq_cut
which I wrote for the purpose. You can also write your own binning function. It just has to take data and nbins as arguments.
summary_fun
is the summary function that is used to aggregate the bins. By default, it s mean
. You can also specify aggregating functions for x and y separately with fun.x
and fun.y
.
- If you use a geom which takes
ymin
and ymax
as aesthetics, you can also specify fun.ymin
and fun.ymax
.
请注意,如果你具体说明aes(组 = 您的宾),bin_fun
就被忽视,而是使用组别变量。 说明还将产生一个可检索到.count.
的变量。
在你看来,你也这样做:
p <- ggplot(data, aes(x, y)) +
geom_point(aes(size = ..count..), stat = "binner") +
ylim(0, 1)
在本案中并不十分有用(尽管这表明了同质,差异大约为0.25,相当于伯尔尼(0.5)的假设,但仅举一例:
p + geom_linerange(stat = "binner",
fun.ymin = function(y) mean(y) - var(y) / 2,
fun.ymax = function(y) mean(y) + var(y) / 2)
该法典:
library(proto)
stat_binner <- function (mapping = NULL, data = NULL, geom = "point", position = "identity", ...) {
StatBinner$new(mapping = mapping, data = data, geom = geom, position = position, ...)
}
StatBinner <- proto(ggplot2:::Stat, {
objname <- "binner"
default_geom <- function(.) GeomPoint
required_aes <- c("x", "y")
calculate_groups <- function(., data, scales, bin_var = "x", nbins = NULL, bin_fun = seq_cut, summary_fun = mean,
fun.data = NULL, fun.y = NULL, fun.ymax = NULL, fun.ymin = NULL,
fun.x = NULL, fun.xmax = NULL, fun.xmin = NULL, na.rm = FALSE, ...) {
data <- remove_missing(data, na.rm, c("x", "y"), name = "stat_binner")
# Same rules as binnedplot in arm package
n <- nrow(data)
if (is.null(nbins)) {
nbins <- if (n >= 100) floor(sqrt(n))
else if (n > 10 & n < 100) 10
else floor(n/2)
}
if (length(unique(data$group)) == 1) {
data$group <- bin_fun(data[[bin_var]], nbins)
}
if (!missing(fun.data)) {
# User supplied function that takes complete data frame as input
fun.data <- match.fun(fun.data)
fun <- function(df, ...) {
fun.data(df$y, ...)
}
} else {
if (!is.null(summary_fun)) {
if (!is.null(fun.x)) message("fun.x overriden by summary_fun")
if (!is.null(fun.y)) message("fun.y overriden by summary_fun")
fun.x <- fun.y <- summary_fun
}
# User supplied individual vector functions
fs_x <- compact(list(xmin = fun.x, x = fun.x, xmax = fun.xmax))
fs_y <- compact(list(ymin = fun.ymin, y = fun.y, ymax = fun.ymax))
fun <- function(df, ...) {
res_x <- llply(fs_x, function(f) do.call(f, list(df$x, ...)))
res_y <- llply(fs_y, function(f) do.call(f, list(df$y, ...)))
names(res_y) <- names(fs_y)
names(res_x) <- names(fs_x)
as.data.frame(c(res_y, res_x))
}
}
summarise_by_x_and_y(data, fun, ...)
}
})
summarise_by_x_and_y <- function(data, summary, ...) {
summary <- ddply(data, "group", summary, ...)
count <- ddply(data, "group", summarize, count = length(y))
unique <- ddply(data, "group", ggplot2:::uniquecols)
unique$y <- NULL
unique$x <- NULL
res <- merge(merge(summary, unique, by = "group"), count, by = "group")
# Necessary for, eg, colour aesthetics
other_cols <- setdiff(names(data), c(names(summary), names(unique)))
if (length(other_cols) > 0) {
other <- ddply(data[, c(other_cols, "group")], "group", numcolwise(mean))
res <- merge(res, other, by = "group")
}
res
}
seq_cut <- function(x, nbins) {
bins <- seq(min(x), max(x), length.out = nbins)
findInterval(x, bins, rightmost.closed = TRUE)
}