1 `ggproto` 对象

1.1 ggplot2 的内部结构

Code

library(tidyverse)
#> Warning: package 'purrr' was built under R version 4.5.2
#> Warning: package 'stringr' was built under R version 4.5.2
#> Warning: package 'forcats' was built under R version 4.5.2
#> ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
#> ✔ dplyr     1.1.4     ✔ readr     2.1.6
#> ✔ forcats   1.0.1     ✔ stringr   1.6.0
#> ✔ ggplot2   4.0.1     ✔ tibble    3.3.0
#> ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
#> ✔ purrr     1.2.0     
#> ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag()    masks stats::lag()
#> ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
p <- ggplot(mpg, aes(displ, hwy, color = drv)) + 
  geom_point(position = "jitter") +
  geom_smooth(method = "lm", formula = y ~ x) + 
  facet_wrap(vars(year)) + 
  ggtitle("A plot for expository purposes")
p

Code

ggprint <- function(x) {
  data <- ggplot_build(x)
  gtable <- ggplot_gtable(data)
  grid::grid.newpage()
  grid::grid.draw(gtable)
  return(invisible(x))
}
ggprint(p)

Code

p_built <- ggplot_build(p)

p_built $data %>% map(head) %>% map(as_tibble)
#> [[1]]
#> # A tibble: 6 × 10
#>       x     y colour  PANEL group shape fill   size alpha stroke
#>   <dbl> <dbl> <chr>   <fct> <int> <dbl> <lgl> <dbl> <lgl>  <dbl>
#> 1  1.81  28.7 #00BA38 1         2    19 NA      1.5 NA       0.5
#> 2  1.83  28.7 #00BA38 1         2    19 NA      1.5 NA       0.5
#> 3  2.79  26.2 #00BA38 1         2    19 NA      1.5 NA       0.5
#> 4  2.82  25.9 #00BA38 1         2    19 NA      1.5 NA       0.5
#> 5  1.82  25.6 #F8766D 1         1    19 NA      1.5 NA       0.5
#> 6  1.79  25.4 #F8766D 1         1    19 NA      1.5 NA       0.5
#> 
#> [[2]]
#> # A tibble: 6 × 14
#>       x     y  ymin  ymax    se flipped_aes colour  PANEL group fill   linewidth
#>   <dbl> <dbl> <dbl> <dbl> <dbl> <lgl>       <chr>   <fct> <int> <chr>      <dbl>
#> 1  1.8   24.3  23.1  25.6 0.625 FALSE       #F8766D 1         1 #9999…         1
#> 2  1.86  24.2  22.9  25.4 0.612 FALSE       #F8766D 1         1 #9999…         1
#> 3  1.92  24.0  22.8  25.2 0.598 FALSE       #F8766D 1         1 #9999…         1
#> 4  1.98  23.9  22.7  25.0 0.585 FALSE       #F8766D 1         1 #9999…         1
#> 5  2.04  23.7  22.6  24.9 0.572 FALSE       #F8766D 1         1 #9999…         1
#> 6  2.10  23.5  22.4  24.7 0.559 FALSE       #F8766D 1         1 #9999…         1
#> # ℹ 3 more variables: linetype <int>, weight <dbl>, alpha <dbl>
p_built $layout
#> <ggproto object: Class Layout, gg>
#>     coord: <ggproto object: Class CoordCartesian, Coord, gg>
#>         aspect: function
#>         backtransform_range: function
#>         clip: on
#>         default: TRUE
#>         distance: function
#>         draw_panel: function
#>         expand: TRUE
#>         is_free: function
#>         is_linear: function
#>         labels: function
#>         limits: list
#>         modify_scales: function
#>         range: function
#>         ratio: NULL
#>         render_axis_h: function
#>         render_axis_v: function
#>         render_bg: function
#>         render_fg: function
#>         reverse: none
#>         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>
#>     coord_params: list
#>     facet: <ggproto object: Class FacetWrap, Facet, gg>
#>         attach_axes: function
#>         attach_strips: function
#>         compute_layout: function
#>         draw_back: function
#>         draw_front: function
#>         draw_labels: function
#>         draw_panel_content: function
#>         draw_panels: function
#>         finish_data: function
#>         format_strip_labels: function
#>         init_gtable: function
#>         init_scales: function
#>         map_data: function
#>         params: list
#>         set_panel_size: function
#>         setup_data: function
#>         setup_panel_params: function
#>         setup_params: function
#>         shrink: TRUE
#>         train_scales: function
#>         vars: function
#>         super:  <ggproto object: Class FacetWrap, Facet, gg>
#>     facet_params: list
#>     finish_data: function
#>     get_scales: function
#>     layout: data.frame
#>     map_position: function
#>     panel_params: list
#>     panel_scales_x: list
#>     panel_scales_y: list
#>     render: function
#>     render_labels: function
#>     reset_scales: function
#>     resolve_label: function
#>     setup: function
#>     setup_panel_guides: function
#>     setup_panel_params: function
#>     train_position: function
#>     super:  <ggproto object: Class Layout, gg>
p_built $plot

Code

p_gtable <- ggplot_gtable(p_built)
p_gtable
#> TableGrob (17 x 17) "layout": 25 grobs
#>     z         cells             name
#> 1   0 ( 1-17, 1-17)       background
#> 2   1 (10-10, 7- 7)        panel-1-1
#> 3   1 (10-10,11-11)        panel-2-1
#> 4   3 ( 8- 8, 7- 7)       axis-t-1-1
#> 5   3 ( 8- 8,11-11)       axis-t-2-1
#> 6   3 (11-11, 7- 7)       axis-b-1-1
#> 7   3 (11-11,11-11)       axis-b-2-1
#> 8   3 (10-10,10-10)       axis-l-1-2
#> 9   3 (10-10, 6- 6)       axis-l-1-1
#> 10  3 (10-10,12-12)       axis-r-1-2
#> 11  3 (10-10, 8- 8)       axis-r-1-1
#> 12  2 ( 9- 9, 7- 7)      strip-t-1-1
#> 13  2 ( 9- 9,11-11)      strip-t-2-1
#> 14  4 ( 7- 7, 7-11)           xlab-t
#> 15  5 (12-12, 7-11)           xlab-b
#> 16  6 (10-10, 5- 5)           ylab-l
#> 17  7 (10-10,13-13)           ylab-r
#> 18  8 (10-10,15-15)  guide-box-right
#> 19  9 (10-10, 3- 3)   guide-box-left
#> 20 10 (14-14, 7-11) guide-box-bottom
#> 21 11 ( 5- 5, 7-11)    guide-box-top
#> 22 12 (10-10, 7-11) guide-box-inside
#> 23 13 ( 4- 4, 7-11)         subtitle
#> 24 14 ( 3- 3, 7-11)            title
#> 25 15 (15-15, 7-11)          caption
#>                                             grob
#> 1                rect[plot.background..rect.717]
#> 2                       gTree[panel-1.gTree.594]
#> 3                       gTree[panel-2.gTree.609]
#> 4                                 zeroGrob[NULL]
#> 5                                 zeroGrob[NULL]
#> 6            absoluteGrob[GRID.absoluteGrob.613]
#> 7            absoluteGrob[GRID.absoluteGrob.613]
#> 8                                 zeroGrob[NULL]
#> 9            absoluteGrob[GRID.absoluteGrob.621]
#> 10                                zeroGrob[NULL]
#> 11                                zeroGrob[NULL]
#> 12                                 gtable[strip]
#> 13                                 gtable[strip]
#> 14                                zeroGrob[NULL]
#> 15 titleGrob[axis.title.x.bottom..titleGrob.676]
#> 16   titleGrob[axis.title.y.left..titleGrob.679]
#> 17                                zeroGrob[NULL]
#> 18                             gtable[guide-box]
#> 19                                zeroGrob[NULL]
#> 20                                zeroGrob[NULL]
#> 21                                zeroGrob[NULL]
#> 22                                zeroGrob[NULL]
#> 23         zeroGrob[plot.subtitle..zeroGrob.714]
#> 24          titleGrob[plot.title..titleGrob.713]
#> 25          zeroGrob[plot.caption..zeroGrob.715]

Code

grid::grid.newpage()

Code

grid::grid.newpage()
grid::grid.draw(p_gtable)

1.2 `ggproto`

Code

prototype()
#> An object of class "classPrototypeDef"
#> Slot "object":
#> <S4 Type Object>
#> 
#> Slot "slots":
#> character(0)
#> 
#> Slot "dataPart":
#> [1] FALSE

参考 ggplot2-book.org/internals#sec-ggproto

Code


# 创建新类，子类继承
NewObject <- ggproto(
  `_class` = NULL, # 类
  `_inherits` = NULL # 继承
)
NewObject 
#> <ggproto object: Class gg>
#>     _inherits: NULL

Code

# 新类
NewClass <- ggproto("NewClass", NULL,
                    # fields     默认值 
                    geom=NA,
                    # methods
                    
                    )

NewClass
#> <ggproto object: Class NewClass, gg>
#>     geom: NA

Code

# 实例
instance <- ggproto(NULL, NewClass,
                    # 字段赋值
                    geom="point"
                    )
instance
#> <ggproto object: Class NewClass, gg>
#>     geom: point
#>     super:  <ggproto object: Class NewClass, gg>

Code

# 继承
NewSubClass <- ggproto("NewSubClass", NewClass)
NewSubClass
#> <ggproto object: Class NewSubClass, NewClass, gg>
#>     geom: NA
#>     super:  <ggproto object: Class NewClass, gg>

1.3 自定义geom_signif

Code

library(ggplot2)
library(grid)

# 自定义 GeomSignif 对象
GeomSignif <- ggproto(`_class` = "GeomSignif",
                      `_inherits` = Geom,
  required_aes = c("x", "y"),
  
  default_aes = aes(
    comparisons = NULL, step_increase = 0.1,
    map_signif_level = TRUE, test = "t.test",
    test.args = list(), y_position = NULL,
    annotations = NULL, tip_length = 0.03
  ),
  
  draw_group = function(data, panel_scales, coord, comparisons, step_increase,
                        map_signif_level, test, test.args, y_position, annotations, tip_length) {
    
    # 提取比较组
    if (is.null(comparisons)) {
      stop("Comparisons must be provided.")
    }
    
    # 计算每组的 y 坐标位置
    y_max <- max(data$y, na.rm = TRUE)
    if (is.null(y_position)) {
      y_position <- y_max + seq(step_increase, by = step_increase, length.out = length(comparisons))
    }
    
    # 创建标记的绘图对象列表
    grobs <- list()
    for (i in seq_along(comparisons)) {
      comp <- comparisons[[i]]
      group1 <- data[data$x == comp[1], "y"]
      group2 <- data[data$x == comp[2], "y"]
      
      # 进行显著性测试
      test_result <- do.call(test, c(list(group1, group2), test.args))
      p_value <- test_result$p.value
      label <- if (map_signif_level) {
        if (p_value < 0.001) "***"
        else if (p_value < 0.01) "**"
        else if (p_value < 0.05) "*"
        else "ns"
      } else {
        format(p_value, digits = 2)
      }
      
      # 绘制显著性标记线条和标签
      grobs <- c(grobs, list(
        grid::linesGrob(
          x = c(mean(comp[1]), mean(comp[2])),
          y = rep(y_position[i], 2),
          gp = grid::gpar(col = "black", lwd = 0.5)
        ),
        grid::textGrob(
          label, x = mean(comp), y = y_position[i] + tip_length,
          gp = grid::gpar(col = "black", fontsize = 10)
        )
      ))
    }
    
    # 返回绘图对象列表
    grid::grobTree(grobs = grobs)
  }
)

# 创建自定义 geom_signif 函数
geom_signif <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
                        na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) {
  layer(
    geom = GeomSignif, mapping = mapping, data = data, stat = stat,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

1 ggproto 对象

1.1 ggplot2 的内部结构

1.2 ggproto

1.3 自定义geom_signif

1 `ggproto` 对象

1.2 `ggproto`