如何从ggplot2对象中提取注释文本用于编写测试单元

我需要编写一个测试单元，检查ggplot2图形中是否存在特定注释，因此得从ggplot2对象里提取注释文本。之前有解决图例标签提取的方法，但注释在对象结构里藏得更深。

示例ggplot2对象代码：

library(ggplot2)
p <- ggplot(mtcars[c(1,15),], aes(x = wt, y = mpg)) + geom_point()
p_with_annot <- p + annotate("text", x = 4, y = 25, label = "Some text")

我尝试用dput()和str()方法，但没找到注释文本，相关输出如下：

dput(p)的输出：

structure(list(data = structure(list(mpg = c(21, 10.4), cyl = c(6, 
8), disp = c(160, 472), hp = c(110, 205), drat = c(3.9, 2.93), 
    wt = c(2.62, 5.25), qsec = c(16.46, 17.98), vs = c(0, 0), 
    am = c(1, 0), gear = c(4, 3), carb = c(4, 4)), row.names = c("Mazda RX4", 
"Cadillac Fleetwood"), class = "data.frame"), layers = list(<environment>), 
    scales = <environment>, mapping = structure(list(x = ~wt, 
        y = ~mpg), class = "uneval"), theme = list(), coordinates = <environment>, 
    facet = <environment>, plot_env = <environment>, labels = list(
        x = "wt", y = "mpg")), class = c("gg", "ggplot"))

str(p)的输出：

List of 9
 $ data       :'data.frame':    2 obs. of  11 variables:
  ..$ mpg : num [1:2] 21 10.4
  ..$ cyl : num [1:2] 6 8
  ..$ disp: num [1:2] 160 472
  ..$ hp  : num [1:2] 110 205
  ..$ drat: num [1:2] 3.9 2.93
  ..$ wt  : num [1:2] 2.62 5.25
  ..$ qsec: num [1:2] 16.5 18
  ..$ vs  : num [1:2] 0 0
  ..$ am  : num [1:2] 1 0
  ..$ gear: num [1:2] 4 3
  ..$ carb: num [1:2] 4 4
 $ layers     :List of 1
  ..$ :Classes 'LayerInstance', 'Layer', 'ggproto', 'gg' <ggproto object: Class LayerInstance, Layer, gg>
    aes_params: list
    compute_aesthetics: function
    compute_geom_1: function
    compute_geom_2: function
    compute_position: function
    compute_statistic: function
    computed_geom_params: list
    computed_mapping: uneval
    computed_stat_params: list
    constructor: call
    data: waiver
    draw_geom: function
    finish_statistics: function
    geom: <ggproto object: Class GeomPoint, Geom, gg>
        aesthetics: function
        default_aes: uneval
        draw_group: function
        draw_key: function
        draw_layer: function
        draw_panel: function
        extra_params: na.rm
        handle_na: function
        non_missing_aes: size shape colour
        optional_aes: 
        parameters: function
        rename_size: FALSE
        required_aes: x y
        setup_data: function
        setup_params: function
        use_defaults: function
        super:  <ggproto object: Class Geom, gg>
    geom_params: list
    inherit.aes: TRUE
    layer_data: function
    map_statistic: function
    mapping: NULL
    position: <ggproto object: Class PositionIdentity, Position, gg>
        compute_layer: function
        compute_panel: function
        required_aes: 
        setup_data: function
        setup_params: function
        super:  <ggproto object: Class Position, gg>
    print: function
    setup_layer: function
    show.legend: NA
    stat: <ggproto object: Class StatIdentity, Stat, gg>
        aesthetics: function
        compute_group: function
        compute_layer: function
        compute_panel: function
        default_aes: uneval
        dropped_aes: 
        extra_params: na.rm
        finish_layer: function
        non_missing_aes: 
        optional_aes: 
        parameters: function
        required_aes: 
        retransform: TRUE
        setup_data: function
        setup_params: function
        super:  <ggproto object: Class Stat, gg>
    stat_params: list
    super:  <ggproto object: Class Layer, gg> 
 $ scales     :Classes 'ScalesList', 'ggproto', 'gg' <ggproto object: Class ScalesList, gg>
    add: function
    clone: function
    find: function
    get_scales: function
    has_scale: function
    input: function
    n: function
    non_position_scales: function
    scales: list
    super:  <ggproto object: Class ScalesList, gg> 
 $ mapping    :List of 2
  ..$ x: language ~wt
  .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
  ..$ y: language ~mpg
  .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
  ..- attr(*, "class")= chr "uneval"
 $ theme      : list()
 $ coordinates:Classes 'CoordCartesian', 'Coord', 'ggproto', 'gg' <ggproto object: Class CoordCartesian, Coord, gg>
    aspect: function
    backtransform_range: function
    clip: on
    default: TRUE
    distance: function
    expand: TRUE
    is_free: function
    is_linear: function
    labels: function
    limits: list
    modify_scales: function
    range: function
    render_axis_h: function
    render_axis_v: function
    render_bg: function
    render_fg: function
    setup_data: function
    setup_layout: function
    setup_panel_guides: function
    setup_panel_params: function
    setup_params: function
    train_panel_guides: function
    transform: function
    super:  <ggproto object: Class CoordCartesian, Coord, gg> 
 $ facet      :Classes 'FacetNull', 'Facet', 'ggproto', 'gg' <ggproto object: Class FacetNull, Facet, gg>
    compute_layout: function
    draw_back: function
    draw_front: function
    draw_labels: function
    draw_panels: function
    finish_data: function
    init_scales: function
    map_data: function
    params: list
    setup_data: function
    setup_params: function
    shrink: TRUE
    train_scales: function
    vars: function
    super:  <ggproto object: Class FacetNull, Facet, gg> 
 $ plot_env   :<environment: R_GlobalEnv> 
 $ labels     :List of 2
  ..$ x: chr "wt"
  ..$ y: chr "mpg"
 - attr(*, "class")= chr [1:2] "gg" "ggplot"

用annotate()添加的注释本质是一个独立的图层，你可以遍历ggplot对象的layers列表，筛选出注释图层后提取标签文本：

方法1：直接遍历图层提取 #

# 获取带注释的ggplot对象
library(ggplot2)
p <- ggplot(mtcars[c(1,15),], aes(x = wt, y = mpg)) + geom_point()
p_with_annot <- p + annotate("text", x = 4, y = 25, label = "Some text")

# 提取所有注释文本
annot_labels <- sapply(p_with_annot$layers, function(layer) {
  # 判断是否是注释图层：annotate生成的图层geom是GeomText，且data为waiver
  if (inherits(layer$geom, "GeomText") && inherits(layer$data, "waiver")) {
    layer$geom_params$label
  }
})

# 过滤掉空值
annot_labels <- unlist(annot_labels[!sapply(annot_labels, is.null)])

运行后annot_labels会得到"Some text"，你可以用这个结果在单元测试里做匹配检查。

方法2：更鲁棒的筛选（适配不同注释类型） #

如果你的注释还有其他类型（比如geom_label），可以扩展判断条件：

extract_annotations <- function(gg_obj) {
  annots <- lapply(gg_obj$layers, function(layer) {
    # 匹配文本类注释的geom
    if (inherits(layer$geom, c("GeomText", "GeomLabel")) && inherits(layer$data, "waiver")) {
      # 优先取aes_params里的label，没有则取geom_params
      label <- layer$aes_params$label %||% layer$geom_params$label
      # 如果是表达式，转成字符
      if (is.expression(label)) as.character(label) else label
    }
  })
  unlist(annots[!sapply(annots, is.null)])
}

# 使用函数提取
extract_annotations(p_with_annot)

这个函数能处理annotate("text")和annotate("label")两种情况，还能兼容表达式类型的注释标签。

为什么之前的方法没找到？ #

因为你示例里的p是还没添加注释的对象，添加注释后的对象是p + annotate(...)，你需要把这个结果赋值给变量（比如p_with_annot）再去查看结构。注释作为新图层存在于layers列表中，其标签文本存储在图层的geom_params或aes_params里。

内容的提问来源于stack exchange，提问作者albifrons