在ggplot2中如何删除所有主题+删除一些数据但保持显示数据的纵横比？

Question

我正在尝试创建一个基本图，然后重新创建同一图的修改版本，没有一些数据，也没有任何其他元素（本质上+ theme_void()）。这里的困难在于保持绘图在两个版本之间保留的数据的准确大小和位置。

\n

假设我有以下情节：

\n

library(ggplot2)\n\n# Sample data frame\nd <- data.frame(group = c("A", "B", "C"),\n                value = c(10, 15, 5))\n\n# Create the original bar plot\ng1 <- ggplot() +\n  geom_col(data = d,\n           aes(x = group, \n               y = value,\n               fill = group)) +\n  theme_bw()\n

\n

\n

目的是创建（并保存为 .SVG）三个图，每个图一个条形（+ theme_void），但位置/大小与第一个图相同。

\n

所需的图 1： \n

\n

所需的图 2: \n

\n

所需的图 3： \n

\n

我想一种可能性是将其他所有内容设为白色/透明，但我想避免这种方法，因为我将进一步操作保存为 .SVG 的绘图，并且这些元素会困扰我（增加复杂性和更大的文件大小）。

\n

我确实想要追求的另一种方法是进入工作流程的中间ggplot2，在正确的时间停止它（绘图上下文已经给出），修改它（如擦除除单个条之外的所有内容），最后渲染修改后的情节。

\n

该包gginnards具有诸如 和 主题之类的功能，delete_layers()可以用运算符替换%+%，但据我所知，它们修改了大小/位置（应该如此，但这不是我想要的）。

\n

我发现的最接近的东西是ggtrace包（特别是“ highjack-ggproto ”）和整个讨论（对我来说仍然非常不透明）grid/grob。

\n

我想我将在未来几周内了解更多关于这些问题的知识，但对此的任何建议将不胜感激！

\n

编辑：从下面有价值的答案中我必须强调：

\n

\n

1. 这是一个玩具示例，真实案例将theme在原始情节上进行大量修改。\xc2\xb4s 就是说，在这种情况下，使第一个图更简单（这将有助于比较）的解决方法不是解决方案。

   \n
\n

2. 目的是将结果保存在干净的 SVG 中。我所说的“干净”是指 SVG 文件中应该只有可见元素（当我检查其源代码时）。例如，如果我的图中有数百个点并且我过滤了一个点，则该单个点应该单独出现在新的 SVG 中（与第一个图中的位置完全相同 - 该图具有多个主题修改，标题、图例、轴等）。

   \n
\n

\n

Answer 1

这其实是相当困难的。问题在于，条形的确切位置是由嵌套视口确定的。最简单的解决方案可能只是遍历gTableggplot 对象并使所有不是条形的对象成为zeroGrobs

让我们从情节本身开始：

library(ggplot2)

# Sample data frame
d <- data.frame(group = c("A", "B", "C"),
                value = c(10, 15, 5))

# Create the original bar plot
g1 <- ggplot() +
  geom_col(data = d,
           aes(x = group, 
               y = value,
               fill = group)) +
  theme_bw()

我们的第一步是将其构建为gTable：

gt <- ggplot_gtable(ggplot_build(g1))

请注意，从现在开始，如果我们想绘制结果，我们可以这样做：

grid::grid.newpage()
grid::grid.draw(gt)

现在，让我们将面板以外的所有内容都设为零。面板始终是 a gTree，所以我们可以这样做：

gt$grobs <- lapply(gt$grobs, function(x) {
  if(class(x)[1] == 'gTree') x else zeroGrob()
  })

请注意，这会擦除除面板之外的所有内容，但所有间距保持不变：

grid::grid.newpage()
grid::grid.draw(gt)

现在我们想在面板中做同样的事情，删除所有不是geom_rectgrob 的东西：

panel <- which(lengths(gt$grobs) > 3)

gt$grobs[[panel]]$children <- lapply(gt$grobs[[panel]]$children, function(x) {
  if(grepl('geom_rect', x)) x else zeroGrob()
})

这样我们就只剩下三个栏了：

grid::grid.newpage()
grid::grid.draw(gt)

为了在自己的图中获得各个条形，我们创建了绘图对象的三个副本

gt_list <- list(gt1 = gt, gt2 = gt, gt3 = gt)

现在我们遍历这个列表并从每个列表中删除除一个栏之外的所有栏：

rectangles <- which(lengths(gt$grobs[[panel]]$children) > 3)

gt_list <- Map(function(x, i) {
  rect <- x$grobs[[panel]]$children[[rectangles]]
  rect$x <- rect$x[i]
  rect$y <- rect$y[i]
  rect$width <- rect$width[i]
  rect$height <- rect$height[i]
  rect$gp <- rect$gp[i]
  x$grobs[[panel]]$children[[rectangles]] <- rect
  x
}, gt_list, seq_along(gt_list))

我们现在有 3 个绘图，每个绘图中只有一个图形对象，但每个图形元素的位置与原始绘图相比没有变化。

grid::grid.newpage()
grid::grid.draw(gt_list[[1]])

grid::grid.newpage()
grid::grid.draw(gt_list[[2]])

grid::grid.newpage()
grid::grid.draw(gt_list[[3]])

此外，我们可以看到生成的 svg 并没有充满不必要的不​​可见对象；仅将栏写入文件：

svg('my.svg')
grid::grid.newpage()
grid::grid.draw(gt_list[[1]])
dev.off()

导致

我的.svg

<?xml version="1.0" encoding="UTF-8"?>
<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="504pt" height="504pt" viewBox="0 0 504 504" version="1.1">
<g id="surface1">
<rect x="0" y="0" width="504" height="504" style="fill:rgb(100%,100%,100%);fill-opacity:1;stroke:none;"/>
<path style=" stroke:none;fill-rule:nonzero;fill:rgb(97.254902%,46.27451%,42.745098%);fill-opacity:1;" d="M 52.492188 451.675781 L 169.050781 451.675781 L 169.050781 168.375 L 52.492188 168.375 Z M 52.492188 451.675781 "/>
</g>
</svg>

如果有人对事情不相符有任何挥之不去的怀疑，让我们保存这些情节并动画化它们来证明这一点：

<?xml version="1.0" encoding="UTF-8"?>
<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="504pt" height="504pt" viewBox="0 0 504 504" version="1.1">
<g id="surface1">
<rect x="0" y="0" width="504" height="504" style="fill:rgb(100%,100%,100%);fill-opacity:1;stroke:none;"/>
<path style=" stroke:none;fill-rule:nonzero;fill:rgb(97.254902%,46.27451%,42.745098%);fill-opacity:1;" d="M 52.492188 451.675781 L 169.050781 451.675781 L 169.050781 168.375 L 52.492188 168.375 Z M 52.492188 451.675781 "/>
</g>
</svg>

^{创建于 2023-08-31，使用reprex v2.0.2}

Answer 2

我是ggtrace的作者。艾伦非常棒，并且已经很好地回答了你的问题（我将在这里无耻地复制他的代表/答案的部分内容），但自从你提到它以来，我忍不住尝试一下 ggtrace 解决方案！

ggtrace 工作流程

第一步是在图层数据即将传递到几何对象时拦截该数据。图层的绘制从ggproto方法开始Geom$draw_layer()，该方法在参数中获取图层的数据data。我所说的“图层数据”的字面意思是layer_data(g1)

g1 <- ggplot() +
  geom_col(data = d,
           aes(x = group, 
               y = value,
               fill = group)) +
  theme_bw()
layer_data(g1)
#>      fill x  y PANEL group flipped_aes ymin ymax xmin xmax colour linewidth linetype alpha
#> 1 #F8766D 1 10     1     1       FALSE    0   10 0.55 1.45     NA       0.5        1    NA
#> 2 #00BA38 2 15     1     2       FALSE    0   15 1.55 2.45     NA       0.5        1    NA
#> 3 #619CFF 3  5     1     3       FALSE    0    5 2.55 3.45     NA       0.5        1    NA

请注意数据的每一行如何代表一个条形。如果我们希望 geom 层只绘制一个条形，我们会劫持传递给的参数Geom$draw_layer()，使其data接收到的参数只是其中一行。我们可以ggtrace_highjack_args()通过传递表达式来做到这一点data = data[1,]（这个赋值就是我们正在做的“劫持”）。为了更好地衡量，我还print(data[1,])让您可以在发生这种情况时检查该值：

gt_bar1 <- ggtrace_highjack_args(
  x = g1, method = Geom$draw_layer,
  values = expression(
    data = print(data[1,])
  )
)
#>      fill x  y PANEL group flipped_aes ymin ymax xmin xmax colour linewidth linetype alpha
#> 1 #F8766D 1 10     1     1       FALSE    0   10 0.55 1.45     NA       0.5        1    NA

gt_bar1

highjack 函数的输出只是另一个 (gtable) grob（带有一个额外的"ggtrace_highjacked"类，仅用于打印方法），因此您可以在事后对其进行常规网格操作。在这里，我复制 Allan 的用于“擦除”gtable 的非条形元素的代码并将其应用到gt_bar1：

class(gt_bar1)
#> [1] "ggtrace_highjacked" "gtable"             "gTree"              "grob"               "gDesc"

wipe_nonbar <- function(gt) {
  gt$grobs <- lapply(gt$grobs, function(x) {
    if(class(x)[1] == 'gTree') x else zeroGrob()
  })
  panel <- which(lengths(gt$grobs) > 3)
  gt$grobs[[panel]]$children <- lapply(gt$grobs[[panel]]$children, function(x) {
    if(grepl('geom_rect', x)) x else zeroGrob()
  })
  gt
}

gt_bar1_wiped <- wipe_nonbar(gt_bar1)
gt_bar1_wiped

最后，我们将此工作流程包装到一个函数中，迭代图层中的条形数量，并将 grobs 保存到列表中gt_bars：

n_bars <- nrow(layer_data(g1))
gt_bars <- lapply(seq_len(n_bars), function(i) {
  bar_gt <- ggtrace_highjack_args(
    x = g1, method = GeomBar$draw_panel,
    values = rlang::exprs(
      data = data[data$group == !!i,]
    )
  )
  wipe_nonbar(bar_gt)
})

动画片：

purrr::iwalk(
  c(list(g1), gt_bars),
  ~ ggsave(filename = paste0(.y, ".png"), plot = .x, path = tempdir())
)
list.files(tempdir(), "\\d.png", full.names = TRUE) |> 
  magick::image_read() |> 
  magick::image_animate(fps = 4)

结尾

您可能想知道为什么我们需要劫持 ggplot，而您也可以这样做geom_col(data = d[1,])。在“渲染时”执行此操作的优点是，您可以使用已针对其他内容（例如位置信息）进行增强的图层数据。所以我们保留位置调整，例如position_stack()：

g2 <- ggplot() +
  geom_col(data = d,
           aes(x = 1, 
               y = value,
               fill = group),
           position = position_stack()) +
  theme_bw()
g2

g2_bar2 <- ggtrace_highjack_args(
  g2, Geom$draw_layer,
  values = expression(
    data = data[2,]
  )
)
g2_bar2

总之，ggtrace 让您减少对“内部因素”（ggproto、网格等）的依赖。条形图是我们可以在语法中表示的结构，因此我们应该对它们进行比其他一些东西更高级别的控制（例如隐藏图中的所有其他元素 - 我们可以让网格拥有该元素）。将这种中级抽象与 ggtrace 一起使用需要一些时间来适应，但如果这引起您的兴趣，请告诉我您还想看到什么更多的 ggtrace-in-action ！

编辑：我对擦除非栏元素的看法

我回到这个问题并尝试了一个wipe_nonbar2()更符合我的“口味”的问题：

wipe_nonbar2 <- function(gt) {
  panel <- which(gt$layout$name == "panel")
  gt$grobs[-panel] <- list(zeroGrob())
  rect <- which(grepl("geom_rect", gt$grobs[[panel]]$childrenOrder))
  gt$grobs[[panel]]$children[-rect] <- list(zeroGrob())
  gt
}

这保留了gListgtable grobs 之一的类（很简单，但它是基于索引的赋值的一个很好的属性，使用list(zeroGrob())：

waldo::compare(wipe_nonbar(gt_bar1), wipe_nonbar2(gt_bar1))
#> `old$grobs[[6]]$children` is a list
#> `new$grobs[[6]]$children` is an S3 object of class <gList>, a list