在 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”的条带等应该合并（实际上它是一个稍微长一些的文本，但这只是为了说明）。我试图为类似的场景调整答案（ - 谢谢@markus 再次找到它），但这是我尝试过的。正如您在下面看到的，我制作的高度似乎不对。我想这一定是我 overlooking/not 理解的一些微不足道的事情。

# 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 -axis 标签，需要安装来自 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)

Answer 1

也许这不能解决问题，但我想 post 因为它可以帮助在保持相同结构的不同情节中呈现结果。您必须在 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

你最终会得到这样的情节：

Answer 2

这是在网格中以一种比较简单的方式进行的表示。我已将“父”方面做得更暗以强调嵌套，但如果您更喜欢匹配的颜色，只需将 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 package (v0.3.0)}

于 2020-07-04 创建

Answer 3

我玩这个游戏有点晚了，但是 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 创建

请记住，这可能仍然存在一些错误。另外，我知道这对 OP 没有帮助，因为他的软件包版本受到限制，但我想我还是在这里提到了这一点。

在 ggplot2 facet_wrap 中跨列组合多个小平面条带

Combine multiple facet strips across columns in ggplot2 facet_wrap

r

facet

ggplot2

gtable

r-grid

------------ 使用 ggh4x 实现更新 ------------------

# 根据示例设置绘图

# 生成刻面条的代码