如何将grobs存储在列表中并将它们传递给grobTree()函数？

Question

我正在尝试创建一个grobs列表，然后将它们传递给grobTree()，但是我的列表项没有被do.call()读取为grobs。

这是我的代码：

library(purrr)
library(grid)
library(gridExtra)
library(ggplot2)
qplot(displ, year, data = mpg)

title_segments <- c('Help ', 'me ', 'please', '!')
colors <- c('red', 'orange', 'green', 'blue')
nudge_x = 0

grobs <- NULL
grobs[1] <- list(gp = gpar(fontsize = 14, fontface = 'bold'))
grobs[2] <- list(textGrob(label = title_segments[1], name = "title1",  
                          x = unit(2.33 - nudge_x, "lines"), 
                          y = unit(-.5, "lines"), 
                          hjust = 0, vjust = 0, gp = gpar(col = colors[1])))

if(length(title_segments) > 1){ 
  x <- unit(2.24 - nudge_x, "lines")
  more_grobs <- pmap(list(title_segments[-1], colors[-1], 
seq_along(title_segments)[-1]), function(segment, color, i){
    grob <- textGrob(label = segment, name = paste0('title', i, sep = ''),
                          x = x + grobWidth(paste0('title', i - 1, sep = '')),     
                          y = unit(-.5, "lines"),
                          hjust = 0, vjust = 0, gp = gpar(col = color))
  })
}
grobs <- c(grobs, more_grobs)

grobs <- do.call(what = grobTree, args = grobs) ### ERROR HERE

# Turn off clipping and draw plot
gb <- ggplot_build(last_plot()) 
gt <- ggplot_gtable(gb) 
gt$layout$clip[gt$layout$name=="panel"] <- "off" 
gg <- arrangeGrob(gt, top = grobs, padding = unit(2.6, "line")) 
grid.newpage() 
grid.draw(gg) 

当我到达do.call()语句时，出现了错误，因为我的列表元素没有被读取为grobs。

当我尝试这段代码时，它会评估为真。

var <- NULL
is.grob(var <- textGrob(label = title_segments[1], name = "title1",  
                      x = unit(2.33 - nudge_x, "lines"), 
                      y = unit(-.5, "lines"), 
                      hjust = 0, vjust = 0, gp = gpar(col = colors[1])))

当我尝试这个代码片段时，它会评估为假。

var2 <-NULL
var2[1] <- textGrob(label = title_segments[1], name = "title1",  
                      x = unit(2.33 - nudge_x, "lines"), 
                      y = unit(-.5, "lines"), 
                      hjust = 0, vjust = 0, gp = gpar(col = colors[1])))
is.grob(var2[1])

编辑：我想通过pmap函数实现以下目标。

grobs <- grobTree(
gp = gpar(fontsize = 14, fontface = 'bold'),

textGrob(label = title_segments[1], name = "title1",
         x = unit(2.33 - nudge_x, "lines"),
         y = unit(-.5, "lines"),
         hjust = 0, vjust = 0, gp = gpar(col = colors[1])),

  if(length(title_segments) > 1){
    textGrob(label = title_segments[2], name = "title2",
           x = grobWidth("title1") + unit(2.24 - nudge_x, "lines"),
           y = unit(-.5, "lines"),
           hjust = 0, vjust = 0, gp = gpar(col = colors[2]))
  },

  if(length(title_segments) > 2){
    textGrob(label = title_segments[3], name = "title3",
           x = grobWidth("title1") + grobWidth("title2") + unit(2.24 - nudge_x, "lines"),
           y = unit(-.5, "lines"),
           hjust = 0, vjust = 0, gp = gpar(col = colors[3]))
  },
  if(length(title_segments) > 3){
    textGrob(label = title_segments[4], name = "title4",
           x = grobWidth("title1") + grobWidth("title2") + grobWidth("title3") +  unit(2.24 - nudge_x, "lines"),
           y = unit(-.5, "lines"),
           hjust = 0, vjust = 0, gp = gpar(col = colors[4]))
  },
  if(length(title_segments) > 4){
    textGrob(label = title_segments[5], name = "title5",
           x = grobWidth("title1") + grobWidth("title2") + grobWidth("title3") + grobWidth("title4") + unit(2.24 - nudge_x, "lines"),
           y = unit(-.5, "lines"),
           hjust = 0, vjust = 0, gp = gpar(col = colors[5]))
  }
) 

- Christopher Peralta

---

grobs[1] 明显不是一个 grob。 - baptiste

Grobs[1] 应该是 grobTree() 的 gp 参数。这是我正在开发的一个函数的一部分，用于制作多彩的图表标题。我在编辑中发布了未循环版本的代码。 - Christopher Peralta

我已经发布了一个答案，以高效的方式解决了生成未循环代码的特定问题。 - Claus Wilke

Answer 1

让我们试着回答这个问题。按照我的理解，这个问题是这样的：

这段代码是有效的：

grobs <- grobTree(
  gp = gpar(fontsize = 14, fontface = 'bold'),

  textGrob(label = title_segments[1], name = "title1",
           x = unit(2.33 - nudge_x, "lines"),
           y = unit(-.5, "lines"),
           hjust = 0, vjust = 0, gp = gpar(col = colors[1])),

  if(length(title_segments) > 1){
    textGrob(label = title_segments[2], name = "title2",
             x = grobWidth("title1") + unit(2.24 - nudge_x, "lines"),
             y = unit(-.5, "lines"),
             hjust = 0, vjust = 0, gp = gpar(col = colors[2]))
  },

  if(length(title_segments) > 2){
    textGrob(label = title_segments[3], name = "title3",
             x = grobWidth("title1") + grobWidth("title2") + unit(2.24 - nudge_x, "lines"),
             y = unit(-.5, "lines"),
             hjust = 0, vjust = 0, gp = gpar(col = colors[3]))
  },
  if(length(title_segments) > 3){
    textGrob(label = title_segments[4], name = "title4",
             x = grobWidth("title1") + grobWidth("title2") + grobWidth("title3") +  unit(2.24 - nudge_x, "lines"),
             y = unit(-.5, "lines"),
             hjust = 0, vjust = 0, gp = gpar(col = colors[4]))
  },
  if(length(title_segments) > 4){
    textGrob(label = title_segments[5], name = "title5",
             x = grobWidth("title1") + grobWidth("title2") + grobWidth("title3") + grobWidth("title4") + unit(2.24 - nudge_x, "lines"),
             y = unit(-.5, "lines"),
             hjust = 0, vjust = 0, gp = gpar(col = colors[5]))
  }
) 

然而，这段代码旨在对先前的代码进行计算重现，但实际上并没有做到：

grobs <- NULL
grobs[1] <- list(gp = gpar(fontsize = 14, fontface = 'bold'))
grobs[2] <- list(textGrob(label = title_segments[1], name = "title1",  
                          x = unit(2.33 - nudge_x, "lines"), 
                          y = unit(-.5, "lines"), 
                          hjust = 0, vjust = 0, gp = gpar(col = colors[1])))

if(length(title_segments) > 1){ 
  x <- unit(2.24 - nudge_x, "lines")
  more_grobs <- pmap(list(title_segments[-1], colors[-1], 
seq_along(title_segments)[-1]), function(segment, color, i){
    grob <- textGrob(label = segment, name = paste0('title', i, sep = ''),
                          x = x + grobWidth(paste0('title', i - 1, sep = '')),     
                          y = unit(-.5, "lines"),
                          hjust = 0, vjust = 0, gp = gpar(col = color))
  })
}
grobs <- c(grobs, more_grobs)

grobs <- do.call(what = grobTree, args = grobs) ### ERROR HERE

发生了什么？答案在于问题出现在前两行代码中：

grobs <- NULL
grobs[1] <- list(gp = gpar(fontsize = 14, fontface = 'bold'))

这个任务grobs[1] <-移除了列表元素中gp = ...的命名，因此函数grobTree()无法理解第一个参数不是grob。修复方法很简单，用以下代码替换那两行：

grobs <- list(gp = gpar(fontsize = 14, fontface = 'bold'))

现在事情有些进展了。现在do.call()这一行不再出错了。然而，单词之间的间距仍然不对，因为pmap()调用没有创建从第一个到第n个grob的所有宽度的总和。相反，它只使用了前一个grob的宽度。我认为最好用递归函数来解决这个问题：

make_grobs <- function(words, colors, x, y, hjust = 0, vjust = 0, i = 0) {
  n <- length(words)
  colors <- rep_len(colors, n)
  name <- paste0('title', i)
  grob <- textGrob(label = words[1], name = name,
                   x = x, y = y, hjust = hjust, vjust = vjust,
                   gp = gpar(col = colors[1]))
  if (n == 1) {
    list(grob)
  }
  else {
    c(list(grob),
      make_grobs(words[-1], colors[-1],
                 x + grobWidth(grob), y, hjust, vjust, i + 1))
  }
}

定义了这个函数后，整个可重现的示例就变成了：

library(purrr)
library(grid)
library(gridExtra)
library(ggplot2)

title_segments <- c('Help ', 'me ', 'please', '!')
colors <- c('red', 'orange', 'green', 'blue')
nudge_x = 0

grobs <- do.call(what = grobTree, 
                 args = c(make_grobs(title_segments, colors,
                                     x = unit(2.33 - nudge_x, "lines"),
                                     y = unit(-.5, "lines")),
                          list(gp = gpar(fontsize = 14, fontface = 'bold'))))

qplot(displ, year, data = mpg)
gb <- ggplot_build(last_plot()) 
gt <- ggplot_gtable(gb) 
gt$layout$clip[gt$layout$name=="panel"] <- "off" 
gg <- arrangeGrob(gt, top = grobs, padding = unit(2.6, "line")) 
grid.newpage() 
grid.draw(gg) 

- Claus Wilke