在R中组合grid_arrange_shared_legend（）和facet_wrap_labeller（）

Question

我想在R中合并grid_arrange_shared_legend()和facet_wrap_labeller()。更具体地说，我想绘制一个包含两个ggplot数字的图形，每个数字都有多个面板，并且有一个共同的图例。我进一步想要将小部分标签的一部分用斜体字。前者可以使用grid_arrange_shared_legend()函数引入here，而后者可以使用facet_wrap_labeller()函数here来实现。但是，我没有成功地将两者结合起来。

以下是一个例子。

library("ggplot2")
set.seed(1)
d <- data.frame(
  f1 = rep(LETTERS[1:3], each = 100),
  f2 = rep(letters[1:3], 100),
  v1 = runif(3 * 100),
  v2 = rnorm(3 * 100)
)
p1 <- ggplot(d, aes(v1, v2, color = f2)) + geom_point() + facet_wrap(~f1)
p2 <- ggplot(d, aes(v1, v2, color = f2)) + geom_smooth() + facet_wrap(~f1)

我可以将p1和p2放在同一个图中，并使用grid_arrange_shared_legend()（从原始版本略微修改）有一个共同的图例。

grid_arrange_shared_legend <- function(...) {
    plots <- list(...)
    g <- ggplotGrob(plots[[1]] + theme(legend.position = "right"))$grobs
    legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]]
    lheight <- sum(legend$width)
    grid.arrange(
        do.call(arrangeGrob, lapply(plots, function(x)
            x + theme(legend.position = "none"))),
        legend,
        ncol = 2,
        widths = unit.c(unit(1, "npc") - lheight, lheight))
}
grid_arrange_shared_legend(p1, p2)

这是我得到的。

可以通过facet_wrap_labeller()将部分条形标签斜体化。

facet_wrap_labeller <- function(gg.plot,labels=NULL) {
  require(gridExtra)

  g <- ggplotGrob(gg.plot)
  gg <- g$grobs      
  strips <- grep("strip_t", names(gg))

  for(ii in seq_along(labels))  {
    modgrob <- getGrob(gg[[strips[ii]]], "strip.text", 
                       grep=TRUE, global=TRUE)
    gg[[strips[ii]]]$children[[modgrob$name]] <- editGrob(modgrob,label=labels[ii])
  }
  g$grobs <- gg
  class(g) = c("arrange", "ggplot",class(g)) 
  g
}
facet_wrap_labeller(p1, 
  labels = c(
    expression(paste("A ", italic(italic))),
    expression(paste("B ", italic(italic))), 
    expression(paste("C ", italic(italic)))
  )
)

但是，我无法以直截了当的方式将两者结合起来。

p3 <- facet_wrap_labeller(p1, 
  labels = c(
    expression(paste("A ", italic(italic))),
    expression(paste("B ", italic(italic))), 
    expression(paste("C ", italic(italic)))
  )
)
p4 <- facet_wrap_labeller(p2, 
  labels = c(
    expression(paste("A ", italic(italic))),
    expression(paste("B ", italic(italic))), 
    expression(paste("C ", italic(italic)))
  )
)
grid_arrange_shared_legend(p3, p4)
# Error in plot_clone(p) : attempt to apply non-function

有谁知道如何修改其中一个或两个功能，以便它们可以合并？或者还有其他方法可以实现这个目标吗？

Answer 1

你需要传递gtable而不是ggplot，

library(gtable)
library("ggplot2")
library(grid)
set.seed(1)
d <- data.frame(
  f1 = rep(LETTERS[1:3], each = 100),
  f2 = rep(letters[1:3], 100),
  v1 = runif(3 * 100),
  v2 = rnorm(3 * 100)
)
p1 <- ggplot(d, aes(v1, v2, color = f2)) + geom_point() + facet_wrap(~f1)
p2 <- ggplot(d, aes(v1, v2, color = f2)) + geom_smooth() + facet_wrap(~f1)


facet_wrap_labeller <- function(g, labels=NULL) {

  gg <- g$grobs      
  strips <- grep("strip_t", names(gg))

  for(ii in seq_along(labels))  {
    oldgrob <- getGrob(gg[[strips[ii]]], "strip.text", 
                       grep=TRUE, global=TRUE)
    newgrob <- editGrob(oldgrob,label=labels[ii])
    gg[[strips[ii]]]$children[[oldgrob$name]] <- newgrob
  }
  g$grobs <- gg
  g
}


combined_fun <- function(p1, p2, labs1) {

  g1 <- ggplotGrob(p1 + theme(legend.position = "right"))
  g2 <- ggplotGrob(p2 + theme(legend.position = "none")) 

  g1 <- facet_wrap_labeller(g1, labs1)

  legend <- gtable_filter(g1, "guide-box", trim = TRUE)
  g1p <- g1[,-(ncol(g1)-1)]
  lw <- sum(legend$width)

  g12 <- rbind(g1p, g2, size="first")
  g12$widths <- unit.pmax(g1p$widths, g2$widths)
  g12 <- gtable_add_cols(g12, widths = lw)
  g12 <- gtable_add_grob(g12, legend, 
                         t = 1, l = ncol(g12), b = nrow(g12))
  g12
}


test <- combined_fun(p1, p2, labs1 = c(
                      expression(paste("A ", italic(italic))),
                      expression(paste("B ", italic(italic))), 
                      expression(paste("C ", italic(italic)))
                    )
)

grid.draw(test)