在ggplot2的facet_wrap中，如何将多个分面条带跨列合并？

Question

我正在尝试将两个相邻面板的分面条组合在一起（始终有两个具有相同第一个ID变量但具有两种不同情况的相邻面板，让我们称它们为“A”和“B”）。我对我尝试的gtable+grid解决方案并不是特别满意，但不幸的是，我不能使用ggh4x包中的facet_nested()（由于存在各种限制和所需的依赖项，我无法在公司服务器上安装它——我尝试只使用相关代码，但由于依赖关系，这也不容易）。

通过组合顶部分面条来使基本图更易于阅读的最小可行示例如下：

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”所在的条带等应合并（实际上，这是一段稍长的文本，但仅用于说明）。我试图修改类似情景的答案（https://dev59.com/bFkS5IYBdhLWcg3wJDYP#40316170 - 感谢@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)

- Björn

---

这个有帮助吗：https://dev59.com/bFkS5IYBdhLWcg3wJDYP - markus

@markus 谢谢！ZNK对那个问题的回答正是我一直在尝试（但失败）适应到这里的答案（虽然teunbrand的facet_nested的第一个答案可以解决我的问题，但需要安装ggh4x包）。 - Björn

@Björn，是的，那似乎是一个合理的解决方案。感谢您对限制的解释，这对我很有帮助。我也考虑过制作facet_wrap()版本，但分面代码编程太可怕了，所以我决定推迟它，直到有人开始要求它。无论如何，如果您无法安装新的附加组件，这也无法解决您的问题。 - teunbrand

希望能在大约1.5年内升级到R版本（我们的IT部门似乎支持2年一次的升级间隔-可悲的是，这倾向于在间隔结束时变得非常痛苦）。我会用ggh4x方法更新问题的实现。 - Björn

@Björn 你好。我添加了一些代码。我需要展示一个类似于你的图形。我使用了我发布的解决方案，效果很好。希望这能有所帮助，如果不行请多多包涵。 - Duck

Answer 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 package (v0.3.0)于2020年08月12日创建}

请注意，这可能仍存在一些错误。此外，我知道这对原作者没有帮助，因为他的软件包版本受到限制，但我还是想在这里提一下。

- teunbrand

---

这太棒了，谢谢分享！您有没有考虑扩展 strip.position = 以允许一些条带在顶部，一些条带在侧面？另外，您可能知道，当发布链接到您有关联的资源时，您需要在帖子中披露您的关联。也许值得编辑您的帖子以包括您的关联。 - Ian Campbell

是的，我也曾想过这个问题，但我还没有时间思考出好的解决方案并实施它。我对你评论的第二部分有点困惑。我的意思是，是的，我写了这个包，但我只是在业余时间里工作。我不是为一个企业或公司编写它。你认为我编辑的免责声明足够吗？ - teunbrand

是的，那个免责声明很完美（每个关联需公开披露的论点在这篇元帖中有探讨）。再次感谢！ - Ian Campbell

太棒了！谢谢，这真的很有帮助，只用一行代码就解决了这个问题 :D - Elliot

Answer 2

也许这不能解决问题，但我想发布它，因为它可以帮助在保持相同结构的情况下用不同的图形呈现结果。您将需要在 plot_layout(ncol = 4) 中定义图形的列数。此代码使用了 patchwork 包。希望这对您有所帮助。

library(tidyverse)
library(gtable)
library(grid)
library(patchwork)

idx = 1:16

#Data

p1 = expand_grid(id=idx, id2=c("A", "B"), x=1:10) %>%
  mutate(y=rnorm(n=n()))

#Split data
List <- split(p1,p1$id)
#Sketch function
myplot <- function(x)
{
  d <- ggplot(x,aes(x=x,y=y)) +
    geom_jitter() +
    facet_wrap(~id2, nrow = 1, ncol=2)+
    ggtitle(unique(x$id))+
    theme(plot.title = element_text(hjust = 0.5))
  return(d)
}

#List of plots
Lplots <- lapply(List,myplot)
#Concatenate plots
#Create chain for plots
chain <- paste0('Lplots[[',1:length(Lplots),']]',collapse = '+')
#Evaluate the object and create the plot
Plot <- eval(parse(text = chain))+plot_layout(ncol = 4)+
  plot_annotation(title = 'A nice plot')&theme(plot.title = element_text(hjust=0.5))
#Display
Plot

你最终会得到这样的一个图表：

- Duck

Answer 3

以下是使用grid的一种较为普通的reprex方法。我将“parent”面板设置成了较深的颜色以突出嵌套关系，但如果你喜欢颜色匹配，只需将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”：

或者如果您想要为循环的每个周期分配不同的填充：

显然，上述方法可能需要进行一些微调，以适应具有不同级别数量的其他图。

^{本文创建于2020-07-04，使用reprex软件包(v0.3.0)}

- Allan Cameron