我认为创建所需情节的最有效方法包括三个步骤：
- 编写两个单独的简单统计数据（在https://cran.r-project.org/web/packages/ggplot2/vignettes/extending-ggplot2.html 的创建新统计数据部分之后）：一个用于在百分位位置添加垂直线，另一个用于添加文本标签；
- 根据需要将刚刚写入的统计信息与参数组合到所需的统计信息中；
- 使用工作成果。
所以答案也包括三个部分。
第 1 部分。在百分位位置添加垂直线的统计数据应根据 x 轴中的数据计算这些值，并以适当的格式返回结果。代码如下：
library(ggplot2)
StatPercentileX <- ggproto("StatPercentileX", Stat,
compute_group = function(data, scales, probs) {
percentiles <- quantile(data$x, probs=probs)
data.frame(xintercept=percentiles)
},
required_aes = c("x")
)
stat_percentile_x <- function(mapping = NULL, data = NULL, geom = "vline",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatPercentileX, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
添加文本标签的统计信息也是如此（默认位置在图的顶部）：
StatPercentileXLabels <- ggproto("StatPercentileXLabels", Stat,
compute_group = function(data, scales, probs) {
percentiles <- quantile(data$x, probs=probs)
data.frame(x=percentiles, y=Inf,
label=paste0("p", probs*100, ": ",
round(percentiles, digits=3)))
},
required_aes = c("x")
)
stat_percentile_xlab <- function(mapping = NULL, data = NULL, geom = "text",
position = "identity", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE, ...) {
layer(
stat = StatPercentileXLabels, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
我们已经有了非常强大的工具，可以以ggplot2 可以提供的任何方式使用（着色、分组、刻面等）。例如：
set.seed(1401)
plot_points <- data.frame(x_val=runif(100), y_val=runif(100),
g=sample(1:2, 100, replace=TRUE))
ggplot(plot_points, aes(x=x_val, y=y_val)) +
geom_point() +
stat_percentile_x(probs=c(0.25, 0.5, 0.75), linetype=2) +
stat_percentile_xlab(probs=c(0.25, 0.5, 0.75), hjust=1, vjust=1.5, angle=90) +
facet_wrap(~g)
# ggsave("Example_stat_percentile.png", width=10, height=5, units="in")
第 2 部分 尽管为线条和文本标签保留单独的层似乎很自然（尽管计算两次百分位数的计算效率有点低）每次添加两个层非常冗长。特别是对于这个ggplot2 有简单的组合层的方法：将它们放在作为结果函数调用的列表中。代码如下：
stat_percentile_x_wlabels <- function(probs=c(0.25, 0.5, 0.75)) {
list(
stat_percentile_x(probs=probs, linetype=2),
stat_percentile_xlab(probs=probs, hjust=1, vjust=1.5, angle=90)
)
}
使用此功能，可以通过以下命令重现之前的示例：
ggplot(plot_points, aes(x=x_val, y=y_val)) +
geom_point() +
stat_percentile_x_wlabels() +
facet_wrap(~g)
请注意，stat_percentile_x_wlabels 采用所需百分位数的概率，然后将其传递给quantile 函数。这是指定它们的地方。
第 3 部分再次使用组合层的想法，您的问题中的情节可以重现如下：
library(scales)
library(dplyr)
geom_histo_pct_by_group <- function() {
list(geom_histogram(aes(y=unlist(lapply(unique(..group..),
function(grp) {
..count..[..group..==grp] /
sum(..count..[..group..==grp])
}))),
binwidth=0.5, position="dodge"),
scale_y_continuous(labels = percent),
ylab("% of total count by group")
)
}
data = diamonds %>% select(carat, color) %>% filter(color %in% c('H', 'D'))
ggplot(data, aes(carat, fill=color, colour=color)) +
geom_histo_pct_by_group() +
stat_percentile_x_wlabels(probs=c(0.5, 0.9))
# ggsave("Question_plot.png", width=10, height=6, unit="in")
备注
此处解决此问题的方式允许使用百分位线和标签构建更复杂的图；
通过在适当的位置将x 更改为y（反之亦然）、vline 更改为hline、xintercept 更改为yintercept，我们可以为来自 y 的数据定义相同的统计信息-轴;
当然，如果您喜欢使用%>% 而不是ggplot2 的+，您可以像在有问题的帖子中那样将定义的统计信息包装在函数中。我个人不建议这样做，因为它违反了ggplot2 的标准用法。