这实际上是相当困难的。问题在于，栏的确切位置由嵌套视口确定。最简单的解决方案可能只是遍历ggplot对象的gTable，并使所有不是条形图的对象都是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)

现在，让我们把所有不是面板的东西都设为零。面板总是gTree，所以我们可以这样做：

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

请注意，这将擦除除面板以外的所有内容，但保留所有间距：

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

现在我们想在面板中做同样的事情，删除不是geom_rect grob的所有内容：

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)

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

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()

导致

my.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>

如果有任何令人不安的怀疑，事情不排队，让我们保存情节并动画它们来证明这一点：

gt <- ggplot_gtable(ggplot_build(g1))

png('plot1.png')
grid::grid.newpage()
grid::grid.draw(gt)
dev.off()

Map(function(x, f) {
  png(f)
  grid::grid.newpage()
  grid::grid.draw(x)
  dev.off()
}, gt_list, c('plot2.png', 'plot3.png', 'plot4.png'))

library(magick)

list.files(pattern = 'plot\\d+\\.png', full.names = TRUE) |> 
  image_read() |>
  image_join() |> 
  image_animate(fps=4) |> 
  image_write("barplot.gif")

创建于2023-08-31使用reprex v2.0.2

我是ggtrace的作者。Allan很棒，已经很好地回答了你的问题（我将无耻地复制他的reprex/答案的一部分），但自从你提到它，我忍不住给了ggtrace解决方案一个刺！

• 提前道歉-这是我的第一个stackoverflow帖子，我没有足够的声誉来发布图像，所以这些数字只是imgur的链接（我可以回来编辑这个吗？）？）现在使用嵌入式图进行编辑！*

ggtrace工作流

第一步是在图层数据即将传递给geo时截取它。层的绘制从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参数只是其中的一行。我们可以通过传递表达式data = data[1,]来对ggtrace_highjack_args()执行此操作（此赋值是我们正在执行的“劫持”）。为了更好地衡量，我也使用了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

hijack函数的输出只是另一个（gtable）grob（带有一个额外的"ggtrace_highjacked"类，只是用于print方法），因此您可以在事后在其上执行常规的网格操作。在这里，我复制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

最后，我们将此工作流 Package 到一个函数中，并迭代层中的条数，并将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)

Coda

你可能想知道为什么我们需要劫持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、grid等）让步更少。条形图是我们可以在语法中表示的结构，所以我们应该对它们进行比其他一些事情更高级别的控制（比如隐藏图中的所有其他元素-我们可以让grid拥有它）。在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
}

这保留了其中一个gtable grob的gList类（微不足道，但它是使用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

如果您在自定义函数中捕获了主要步骤，则可以遍历图中的每个元素，将alpha设置为0（即透明）的酒吧你不想要的。

myplotfun <- function(x) {
  alpha <- rep(0, 3)
  names(alpha) <- c("A", "B", "C")
  alpha[names(alpha) == x] <- 1
  
  p <- ggplot() +
    geom_col(data = d,
             aes(x = group, 
                 y = value,
                 fill = group,
                 alpha = group), show.legend = FALSE) +
    scale_alpha_manual(values = alpha) +
    theme_void()
  
  ggsave(paste0(x, ".svg"), p, device = "svg")
}

使用purrr::walk()进行迭代。

purrr::walk(c("A", "B", "C"), myplotfun)

如果您将数据转换为factor并指定应保留丢弃的级别，则可以完成第一部分：

library(ggplot2)
library(dplyr)

d <- data.frame(group = as.factor(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_void()

g1

g2 <- d %>% 
  filter(group == "A") %>% 
  ggplot() +
  aes(
    x = group, 
    y = value,
    fill = group
  ) +
  geom_col() +
  scale_fill_discrete(drop = FALSE) +
  scale_x_discrete(drop = FALSE) +
  theme_void()

g2

创建于2023-08-31由reprex package（v1.0.0）
然而，传说是棘手的，到目前为止，我还没有找到一个方法。也许一个适合你的解决方法是生成所有没有图例的图（设置theme(legend.position = "none")），然后在一个额外的步骤中创建图例，并将其放置在适合布局的地方？您可以使用cowplot::get_legend(g1)或ggpubr::get_legend(g1)提取图例。

我改编了@Phil的代码和函数，保留了相同的情节，但隐藏了所有的图例，标题......

myplotfun <- function(x) {
  alpha <- rep(0, 3)
  names(alpha) <- c("A", "B", "C")
  alpha[names(alpha) == x] <- 1
  
  p <- ggplot() +
    geom_col(data = d,
             aes(x = group, 
                 y = value,
                 fill = group,
                 alpha = group)) +
    scale_alpha_manual(values = alpha) +
    theme(
      legend.text = element_text(color = "white"),
      panel.background = element_rect(fill = "white"),
      axis.text = element_blank(),
      axis.ticks = element_blank(),
      axis.title = element_blank(),
      legend.title = element_blank(),
      legend.key=element_rect(fill = "white")) +
    guides(fill = guide_legend(override.aes = list(alpha = 0, fill = "white"))) 

  ggsave(paste0(x, ".svg"), p, device = "svg")
  
}

purrr::walk(c("A", "B", "C"), myplotfun)
  
  ggsave(paste0(x, ".svg"), p, device = "svg")
}

purrr::walk(c("A", "B", "C"), myplotfun)