在ggplot2 facet_wrap中跨列组合多个方面条
Bjö*_*örn 5 r facet ggplot2 gtable r-grid
我试图在两个相邻面板上组合刻面条（总是有两个相邻面板具有相同的第一个 ID 变量，但有两种不同的场景，我们称它们为“A”和“B”）。我并不特别拘泥于gtable+grid解决方案，我试过了，但遗憾的是我不能使用facet_nested()从ggh4x包（我不能我公司的安装在服务器上，由于已经到位的各种限制和所需的依赖-我看着只使用相关的代码，但由于依赖关系，这也不容易）。
我希望通过组合顶部刻面条来指示哪些面板“属于一起”，从而使基本图的最小可行示例更易于阅读，如下所示：
library(tidyverse)
library(gtable)
library(grid)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_wrap(~id + id2, nrow = 4, ncol=8)
带有“1”的条带、带有“2”的条带等应该组合在一起（实际上它是一个稍长的文本，但这只是为了说明）。我试图为类似的情况调整答案（/sf/answers/2822131931/ - 谢谢@markus 再次找到它），但这就是我尝试过的。正如你在下面看到的，我生产的高度似乎是错误的。我认为这一定是我忽略/不理解的一些微不足道的事情。
# Combine strips for a ID
g <- ggplot_gtable(ggplot_build(p1))
strip <- gtable_filter(g, "strip-t", trim = FALSE)
stript <- which(grepl('strip-t', g$layout$name))
stript2 = stript[idx*2-1]
top <- strip$layout$t[idx*2-1]
# # Using the $b below instead of b = top[i]+1, also seems not to work
#bot <- strip$layout$b[idx*2-1]
l <- strip$layout$l[idx*2-1]
r <- strip$layout$r[idx*2]
mat <- matrix(vector("list",
length = length(idx)*3),
nrow = length(idx))
mat[] <- list(zeroGrob())
res <- gtable_matrix("toprow", mat,
unit(c(1, 0, 1), "null"),
unit( rep(1, length(idx)),
"null"))
for (i in 1:length(stript2)){
if (i==1){
zz <- res %>%
gtable_add_grob(g$grobs[[stript2[i]]]$grobs[[1]], 1, 1, 1, 3) %>%
gtable_add_grob(g, .,
t = top[i],
l = l[i],
b = top[i]+1,
r = r[i],
name = c("add-strip"))
} else {
zz <- res %>%
gtable_add_grob(g$grobs[[stript2[i]]]$grobs[[1]], 1, 1, 1, 3) %>%
gtable_add_grob(zz, .,
t = top[i],
l = l[i],
b = top[i]+1,
r = r[i],
name = c("add-strip"))
}
}
grid::grid.draw(zz)
------------ 使用 ggh4x 实现更新 -----------------
这可能会为许多人解决此类问题，但也有其缺点（例如，跨行的轴对齐有点手动，可能需要手动删除 x 轴并确保限制相同，添加统一的 y 轴标签，需要从 github 安装软件包：devtools::install_github("teunbrand/ggh4x@v0.1")对于特定版本，加上 cowplot 与例如 ggtern 的交互很差）。所以我会喜欢它，如果有人仍然设法做一个纯gtable+grid版本。
library(tidyverse)
library(ggh4x)
library(cowplot)
plots = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n()),
plotrow=(id-1)%/%4+1) %>%
group_by(plotrow) %>%
group_map( ~ ggplot(data=.,
aes(x=x,y=y)) +
geom_jitter() +
facet_nested( ~ id + id2, ))
plot_grid(plotlist = plots, nrow = 4, ncol=1)
我玩这个游戏有点晚了，但是 ggh4x 现在有一个facet_nested_wrap()可以大大简化这个问题的实现（免责声明：我写了 ggh4x）。
library(tidyverse)
library(ggh4x)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_nested_wrap(~id + id2, nrow = 4, ncol=8)
p1
由reprex 包(v0.3.0)于 2020 年 8 月 12 日创建
请记住，这可能仍然存在一些错误。另外，我知道这对 OP 没有帮助，因为他的软件包版本受到限制，但我想我还是在这里提到了这一点。
这是在网格中执行此操作的一种有点行人方式的表示。我已将“父”面设置得更暗以强调嵌套，但如果您更喜欢颜色匹配，只需将填充rectGrob颜色更改为“gray85”即可。
# 根据示例设置绘图
library(tidyverse)
library(gtable)
library(grid)
idx = 1:16
p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
mutate(y=rnorm(n=n())) %>%
ggplot(aes(x=x,y=y)) +
geom_jitter() +
facet_wrap(~id + id2, nrow = 4, ncol=8)
g <- ggplot_gtable(ggplot_build(p1))
# 生成小平面条的代码
stript <- grep("strip", g$layout$name)
grid_cols <- sort(unique(g$layout[stript,]$l))
t_vals <- rep(sort(unique(g$layout[stript,]$t)), each = length(grid_cols)/2)
l_vals <- rep(grid_cols[seq_along(grid_cols) %% 2 == 1], length = length(t_vals))
r_vals <- rep(grid_cols[seq_along(grid_cols) %% 2 == 0], length = length(t_vals))
labs <- levels(as.factor(p1$data$id))
for(i in seq_along(labs))
{
filler <- rectGrob(y = 0.7, height = 0.6, gp = gpar(fill = "gray80", col = NA))
tg <- textGrob(label = labs[i], y = 0.75, gp = gpar(cex = 0.8))
g <- gtable_add_grob(g, filler, t = t_vals[i], l = l_vals[i], r = r_vals[i],
name = paste0("filler", i))
g <- gtable_add_grob(g, tg, t = t_vals[i], l = l_vals[i], r = r_vals[i],
name = paste0("textlab", i))
}
grid.newpage()
grid.draw(g)
并演示将rectGrob高度更改为 50% 和“gray85”：
或者，如果您愿意，可以为循环的每个周期分配不同的填充：
显然，上述方法可能需要进行一些调整才能适应具有不同级别数等的其他图。
由reprex 包(v0.3.0)于 2020-07-04 创建