参考：
ggplot2高级:构建自己的图层
Extending ggplot2
r - 从头开始创建geom / stat
扩展ggplot2：如何构建geom和stat？
编写ggplot自定义几何函数
诹图
前面写道如何添加平均值【ggplot2】 不同情形添加平均值，
想用图层来完成。
效果：每一个分组添加最大值最小值水平线
image.png
实践：
Part1.画一个图层，快速画出max,min 水平线
p <- ggplot(mtcars, aes(mpg, wt)) +
geom_point() +
facet_wrap(~ cyl)
cdat <- mtcars %>% group_by(cyl) %>% dplyr::summarise(m=mean(wt))
p + geom_hline(data=cdat,aes(yintercept=m))
###
StatSummaryTest <- ggproto("StatSummaryTest", Stat,
required_aes = c("x","y"),
compute_group = function(data, scales,params,
func=mean){
x=range(data$x)
y=func(data$y)
grid=data.frame(x,y)
}
)
stat_summary_test <- function(mapping = NULL, data = NULL, geom = "line",
position = "identity", na.rm = TRUE, show.legend = NA,
inherit.aes = TRUE, func=mean,...){
layer(
stat = StatSummaryTest, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(func=func,na.rm = na.rm, ...)
)
}
ggplot(mtcars, aes(mpg, wt,color=factor(cyl))) +
geom_point()+
stat_summary_test(func=max)+
stat_summary_test(func=min)+
facet_grid(.~factor(cyl),space = "free",scales = "free")
画出平均值
ggplot(mtcars, aes(mpg, wt,color=factor(cyl))) +
geom_point()+
stat_summary_test(func=mean)+
facet_grid(.~factor(cyl),space = "free",scales = "free")
image.png
Part2.画一个类似地毯图图层（地毯图一般为线条）
文章里面图片风格
image.png
p <- ggplot(mtcars, aes(mpg, wt)) +
geom_point() +
facet_wrap(~ cyl)
cdat <- mtcars %>% group_by(cyl) %>% dplyr::summarise(m=mean(wt))
p + geom_hline(data=cdat,aes(yintercept=m))
###
StatRugPoint <- ggproto("StatRugPoint ", Stat,
required_aes = c("x","y"),
compute_group = function(data, scales,params,
sides="b"){
if(sides=="b"){
x=data$x
y=-Inf
} else if(sides=="t"){
x=data$x
y=Inf
} else if(sides=="l"){
x=-Inf
y=data$y
} else if (sides=="r"){
x=Inf
y=data$y
} else {
print("check inpur type")
}
grid=data.frame(x,y)
}
)
stat_rug_point <- function(mapping = NULL, data = NULL, geom = "point",
position = "identity", na.rm = TRUE, show.legend = NA,
inherit.aes = TRUE, sides="b",...){
layer(
stat = StatRugPoint, data = data, mapping = mapping, geom = geom,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(sides=sides,na.rm = na.rm, ...)
)
}
ggplot(mtcars, aes(mpg, wt,color=factor(cyl))) +
geom_point()+
stat_rug_point(sides="b",size=4,alpha=I(0.5))
# ggplot(mtcars, aes(mpg, wt,color=mpg)) +
# geom_point()+
# stat_rug_point(sides ="b",size=4)
image.png
Part3. 模仿geom_rug 代码
主要segmentGrod 变成circleGrod,有些参数没有delete 。
library(grid)
geom_rug2 <- function(mapping = NULL, data = NULL,
stat = "identity", position = "identity",
...,
outside = FALSE,
sides = "bl",
length = unit(0.03, "npc"),
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomRug2 ,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
outside = outside,
sides = sides,
length = length,
na.rm = na.rm,
...
)
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomRug2 <- ggproto("GeomRug2", Geom,
optional_aes = c("x", "y"),
draw_panel = function(data, panel_params, coord, sides = "bl", outside = FALSE, length = unit(0.03, "npc")) {
if (!inherits(length, "unit")) {
abort("'length' must be a 'unit' object.")
}
rugs <- list()
data <- coord$transform(data, panel_params)
# For coord_flip, coord$tranform does not flip the sides where to
# draw the rugs. We have to flip them.
if (inherits(coord, 'CoordFlip')) {
sides <- chartr('tblr', 'rlbt', sides)
}
# move the rug to outside the main plot space
rug_length <- if (!outside) {
list(min = length, max = unit(1, "npc") - length)
} else {
list(min = -1 * length, max = unit(1, "npc") + length)
}
gp <- gpar(fill= data$fill,col = alpha(data$colour, data$alpha), size=data$size)
if (!is.null(data$x)) {
if (grepl("b", sides)) {
rugs$x_b <- circleGrob(
x = unit(data$x, "native"),
y = unit(0, "npc")+ rug_length$min,
r = rug_length$min,
gp = gp
)
}
if (grepl("t", sides)) {
rugs$x_t <- circleGrob(
x = unit(data$x, "native"),
y = unit(1, "npc")- rug_length$max,
r = rug_length$max,
gp = gp
)
}
}
if (!is.null(data$y)) {
if (grepl("l", sides)) {
rugs$y_l <- circleGrob(
y = unit(data$y, "native"),
x = rug_length$min ,
r = rug_length$min ,
gp = gp
)
}
if (grepl("r", sides)) {
rugs$y_r <- circleGrob(
y = unit(data$y, "native"),
x0 = rug_length$max ,
r = rug_length$max ,
gp = gp
)
}
}
gTree(children = do.call("gList", rugs))
},
default_aes = aes(colour = "black", size = 0.1, linetype = 1, alpha = NA),
draw_key = draw_key_path
)
ggplot(mtcars, aes(mpg, wt,color=mpg)) +
geom_point()+
geom_rug2(length = unit(0.01, "npc"))
# ggplot(mtcars, aes(mpg, wt,color=factor(cyl))) +
# geom_point()+
# stat_rug_point(sides="b",size=4,alpha=I(0.5))
image.png
思考：
1.尝试 Part2 时候，发现了一个bug, 颜色只能是factor ,对于梯度颜色，地毯图点为黑色，有点没搞清楚。
2.尝试Part3,模仿geom_rug 脚本就行修改，也发现不完善地方，地毯图填充颜色是个固定值，可能是par() 参数有些问题。后面学习深入了，再进行修改吧~
欢迎评论交流~
