你的 ggplot绘图脚本是否已经臃肿不堪、难以维护？曾经实现的功能不知如何复用？本文的目的是解决这些问题，让你的绘图脚本从此清清爽爽。

本文涉及赋予变量、自定义函数、扩展 ggplot三大技巧，前两种使用门槛较低，刚入门 ggplot的朋友也可以很快掌握。扩展 ggplot会涉及面向对象编程，但它的功能也最强大——你可以控制画面上任意一个点、一条线，这正是 ggplot众多扩展包使用的技巧。

掌握一些辅助函数，对理清 ggplot对象非常有帮助。例如：

1. 对于一个函数，如 element_text(), 直接输入函数名 element_text会显示函数代码，加问号 ?element_text会显示函数文档，element_text()会得到默认返回值。
2. 对于一个对象，class()获取其类名，str()获取其内部结构。
3. 使用 waldo::compare()比较对象前后差异。

赋予变量

library(tidyverse)
ggplot(mpg, aes(x=class, y=cty)) + 
    geom_jitter(aes(fill=class), shape=21, color='grey50', width=0.2) +
    geom_errorbar(stat='summary', fun.min=mean, width=0.4) +
    geom_errorbar(stat='summary', fun.min=~mean(.x)-sd(.x), fun.max=~mean(.x)+sd(.x), width=0.3) +
    scale_fill_brewer(palette='Accent') +
    coord_flip() +
    theme_classic(base_size=10) +
    theme(
        axis.text.x=element_text(angle=45, hjust=1, vjust=1), 
        axis.title=element_blank()
    )

以上是一个标准的绘图程序，创建画布、绘制散点图层、绘制均值标记图层、绘制标准差标记图层、调整 fill刻度、坐标轴变换、设定基础主题、调整主题。实际上，被 +分隔的每一项都可以赋值给变量，这意味着将变量自由组合，就可以在不同绘图任务中复用。

a <- ggplot(mpg, aes(x=class, y=cty))
b <- geom_jitter(aes(fill=class), shape=21, color='grey50', width=0.2)
c <- geom_errorbar(stat='summary', fun.min=mean, width=0.4)
d <- geom_errorbar(stat='summary', fun.min=~mean(.x)-sd(.x), fun.max=~mean(.x)+sd(.x), width=0.3)
e <- scale_fill_brewer(palette='Accent')
f <- coord_flip()
g <- theme_classic(base_size=10)
h <- theme(
        axis.text.x=element_text(angle=45, hjust=1, vjust=1), 
        axis.title=element_blank()
    )

a + b + c + d + e + f + g + h

除了每一项单独相加，也可以将多项存储到 list中：

xx <- list(
    geom_errorbar(stat='summary', fun.min=mean, width=0.4),
    geom_errorbar(stat='summary', fun.min=~mean(.x)-sd(.x), fun.max=~mean(.x)+sd(.x), width=0.3)
    )
a + b + xx + e + f + g + h

预设的变量也可以存储到 list中，然后用 do.call()调用：

tlist <- list(axis.text.x=element_text(angle=45, hjust=1, vjust=1), 
        axis.title=element_blank())
h <- do.call('theme', tlist)

通过 class()和 str()可以观察到：

1. 成品图是 ggplot对象，而，ggplot(...)创建画布这个步骤，返回的已经是 ggplot对象。a$data可以取出 tibble对象的数据集，a$mapping可以取出 uneval对象的美学映射。
2. 三个图层都是 Layer对象，继承自 ggproto类。b$data, b$mapping, b$geom, b$stat, b$position可以分别取出 tibble, uneval, Geom, Stat, Position对象，对应图层的五大要素，后三者都继承自 ggproto类。b$constructor可取出代码语句。
3. 美学刻度调整是 Scale对象，继承自 ggproto类。e$aesthetics返回调节的具体刻度, e$call可检查调用的底层 scale函数。
4. 坐标轴转换是 Coord对象，继承自 ggproto类。
5. 基础主题、主题调整都是 theme对象。

自定义函数

我们可以将绘制均值、标准差两个图层封装到一个函数中，并允许选择是否绘制标准差

geom_meansdbar <- function(sd=TRUE) {
    list(
        geom_errorbar(stat='summary', fun.min=mean, width=0.4),
        if (sd) {geom_errorbar(stat='summary', 
            fun.min=~mean(.x)-sd(.x), fun.max=~mean(.x)+sd(.x), width=0.3)}
    )
}
a + b + geom_meansdbar() + e + f + g + h

如果需要调整不同图层的参数，相比于直接增加 geom_meansdbar()的参数，更合理的方式是

geom_meansdbar <- function(..., sd=TRUE, mean_params=list(), sd_params=list()) {
    params <- list(stat='summary', ...)

    mean_params <- modifyList(mean_params,
        c(params, fun.min=mean, width=0.4))
    sd_params <- modifyList(sd_params,
        c(params, fun.min=~mean(.x)-sd(.x), fun.max=~mean(.x)+sd(.x), width=0.3))

    mean_bar <- do.call('geom_errorbar', mean_params)
    sd_bar <- if (sd) do.call('geom_errorbar', sd_params)

    list(mean_bar, sd_bar)
}
a + b + geom_meansdbar() + e + f + g + h

这种写法明确区分不同图层的参数，同时用 ...接收多个图层的共享参数。

有时你可能想仅指定 data, x, y，让函数直接返回一整幅图。mapping=aes(...)内遵循数据屏蔽（data masking）规则，不需要通过 x=mpg[['class']]的形式指定列，这在大多数时候方便了我们的数据操作，而它的代价之一是出现了两种类型的变量：环境变量（environment variable）和数据变量（data variable），显然 aes()使用数据变量。在自定义函数中，需要使用 {{x}}的形式引用数据变量。

myplot <-  function(data, x, y) {
    ggplot(data, aes(x={{x}}, y={{y}})) + 
        geom_jitter(aes(fill=class), shape=21, color='grey50', width=0.2) +
        geom_meansdbar() +
        scale_fill_brewer(palette='Accent') +
        coord_flip() +
        theme_classic(base_size=10) +
        theme(
            axis.text.x=element_text(angle=45, hjust=1, vjust=1), 
            axis.title=element_blank()
        )
}

myplot(mpg, class, cty)

扩展ggplot

当需求进一步复杂，且没有现成的包可以使用时，可能需要自行扩展 ggplot。最有用的扩展是定义新的统计变换（StatXXX类）和几何对象（GeomXXX类），这些都离不开 ggproto面向对象系统。

ggproto面向对象系统

由于历史原因，ggplot使用独特的面向对象系统 ggproto，该系统习惯的命名方式是驼峰法。在对象内部存储的数据称为字段（fields），函数称为方法（methods）。

# 新建类
Person <- ggproto('Person', NULL,
    name = NA,
    gender = NA,

    description = function(self) {
        paste(self$name, self$gender, sep=', ')
    }
)

# 类继承
Student <- ggproto('Student', Person,
    univ = NA,
    major = NA,

    school = function(self) {
        paste(self$univ, self$major, sep=', ')
    }
)

# 实例化
william <- ggproto(NULL, Student, 
        name = 'william',
        gender = 'male',
        univ = 'Peking Univ',
        major = 'Biology'
)

# 提取字段
william$name

# 调用方法
william$school()

需要注意的是，ggproto面向对象系统仅在 ggplot中使用，而且 ggplot也不会用到该系统的所有功能。在扩展 ggplot时，并不建议从头创建新类，继承已有的类就足矣实现各种目标。

自定义Stat类

新建名为 StatNewstat、继承自 Stat的 ggproto类，就能以 geom_xxx(stat='newstat')的形式调用自定义的统计变换。

在继承时，类属性 required_aes指定了需要映射的刻度，几个类方法非常关键：

1. setup_params = function(data, params)方法，提前算好后续计算需要的参数。例如密度图中，考虑不同构面的数据，最终计算出一个合适的带宽。函数内可通过 params$var引用在 layer(params=list(...))中指定的参数，但有个限制条件，这个参数必须在 compute_group(...)中也出现，否则找不到。
2. setup_data = function(data, params)方法，对数据进行预处理，默认应用到整张数据表上。这里的参数已经被 setup_params()修改过了。
3. compute_group = function(data, scales)方法，对数据进行最终的统计变换，默认应用到被 group列分割后的各子表上。可以在 function(data, scales, var1, var2, ...)参数列表中直接写 layer(params=list(...))中指定的参数。其实 setup_data可以完成等效操作，只需额外划分组别。

未在 geom_xxx(mapping=aes(...))显式指定 group的映射时，该列会自动生成（早在 setup_params()之前），为数据分配组别。

可从 scales获取一系列有用的信息，例如 scales$y$range$range获取 y轴数据范围，scales$y$trans$name获取 y轴使用的尺度变换（如 scale_y_log10(), scale_y_reverse()），scales$x$map('x1')获取离散 x变量值对应 x轴坐标。

下列代码定义了一个 Stat类，会将 x,y坐标的均值指定为坐标原点 (0, 0)。它的用途并不广泛，但作为展示非常清晰。可以看到，方法 compute_group内并没有显式指定分组计算，但不同构面的统计变换都是独立的。

StatCenter <- ggproto('StatCenter', Stat,
    compute_group = function(data, scales) {
        mean_x <- mean(data$x, na.rm=TRUE)
        mean_y <- mean(data$y, na.rm=TRUE)
        data$x <- data$x - mean_x
        data$y <- data$y - mean_y
        return (data)
    },
    required_aes = c('x', 'y')
)

mpg %>% ggplot(aes(x=cty, y=hwy)) + geom_point(stat='center') + facet_wrap(~class, scales='free')

一般也会定义 stat_newstat()函数，该函数返回 Layer对象。这样可以设定默认的 Geom，并在有需要时添加额外参数。

stat_center <- function(mapping = NULL, data = NULL, geom = 'point',
                       position = 'identity', na.rm = FALSE, show.legend = NA, 
                       inherit.aes = TRUE, ...) {
  layer(
    stat = StatCenter, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

mpg %>% ggplot(aes(x=cty, y=hwy)) + stat_center() + facet_wrap(~class, scales='free')

自定义Geom类

新建名为 GeomNewgeom、继承自 Geom的 ggproto类，就能以 stat_xxx(geom='newstat')的形式调用自定义的几何元素。

在继承时，类属性 required_aes指定了经过统计变换后、会被类方法调用的数据列。类方法 draw_group调用 ggplot和/或 grid包创建几何元素，返回 gList或 gTree（较复杂时）对象。

在 draw_group方法内部，使用 ggplot创建几何元素时，主要调用 GeomXXX类的 draw_panel(data, panel_params, coord, ...)方法，其中 data是统计变换后的、被 default_aes修改后的数据，除了 x,y外也包括 size, colour, fill等属性。当然，也可以做额外的手动修改，注意描边颜色始终用 colour而不是 color。

调用了什么 GeomXXX类，就需要最终传入的数据具有对应的列，例如 GeomPoint需要 colour, size等列，GeomSegment需要 linewidth, linetype等列，GeomText需要 angle, hjust, family, lineheight等列。遇到报错时，可以对照 ggplot2的github源码，查看 default_aes漏掉了什么属性。

通过 panel_params也可以获取画面信息，例如 panel_params$y.range获取 y轴显示范围。

也可以使用 grid包创建几何元素，但更复杂、与 ggplot的操作习惯有差别，如果不涉及非常底层的操作，不建议这么做。这种方式主要调用 xxxGrob()函数，传入的 x,y坐标单位是画面比例，这就需要先用 coords <- coord$transform(data, panel_params)转换坐标，然后以 coords$x, coords$y的形式调用。通过 xxxGrob()的 gp=gpar()参数指定属性。作为 grid包的扩展，gridExtra包提供了更多 xxxGrob()函数，例如椭圆。

下列代码定义了一个 Geom类，会在 (x,y)坐标上画点，并连接点和坐标原点，同样是展示目的。

GeomLinkpoint <- ggproto('GeomLinkpoint', Geom,
     required_aes = c('x', 'y'),
     default_aes = aes(colour = 'black', linewidth = .5, fill = NA, alpha = NA, 
                       size = 2, linetype = 1, shape = 19, stroke = 1),
     draw_group = function(data, panel_params, coord, ...) {
         point <- transform(data)
         link <- transform(data, xend = 0, yend = 0)
       
         grid::gList(
             GeomSegment$draw_panel(link, panel_params, coord, ...),
             GeomPoint$draw_panel(point, panel_params, coord, ...)
         )
     }
)

mpg %>% ggplot(aes(x=cty, y=hwy)) + stat_center(geom='linkpoint') + facet_wrap(~class, scales='free')

一般也会定义 geom_newgeom()，该函数返回 Layer对象。这样可以设定默认的 Stat，并在有需要时添加额外参数。

geom_linkpoint <- function(mapping = NULL, data = NULL, 
                       stat = 'center', position = 'identity', 
                       ..., na.rm = FALSE, show.legend = NA, 
                       inherit.aes = TRUE) {
  layer(
    data = data, 
    mapping = mapping, 
    geom = GeomLinkpoint, 
    stat = stat, 
    position = position, 
    show.legend = show.legend, 
    inherit.aes = inherit.aes, 
    params = list(na.rm = na.rm, ...)
  )
}

mpg %>% ggplot(aes(x=cty, y=hwy)) + geom_linkpoint() + facet_wrap(~class, scales='free')

有时，可能只想修改原 Geom的默认设置，那就不需从底层 Geom继承。

GeomHollowpoint <- ggproto('GeomHollowpoint', GeomPoint,
     default_aes = aes(colour = 'black', linewidth = .5, fill = NA, alpha = NA, 
                       size = 2, linetype = 1, shape = 21, stroke = 1.5)
)

mpg %>% ggplot(aes(x=cty, y=hwy)) + stat_center(geom='hollowpoint') + facet_wrap(~class, scales='free')

Stat和Geom实例

在实际扩展 ggplot功能时，最常见的需求有三个：

1. 为自定义的 geom_xxx()增加额外参数，并在统计变换时调用。
2. 指定是否绘制图形的某一部分。
3. 统计变换可以汇总数据、创建新列，为绘制提供便利。

以下代码创建了名为 Skinnybox的新型几何对象，默认将中位数绘制为空心圆点，在上方绘制75%分位数到最大值的细线，在下方绘制25%分位数到最小值的细线。增加 lower_prob, upper_prob参数，允许控制分位数的范围；增加 show_median参数，指定是否绘制中位数。

StatSkinnybox <- ggproto('StatSkinnybox', Stat, 
     compute_group = function(data, scales, na.rm, lower_prob, upper_prob) {
       
         data <- dplyr::summarise(data,
             x = median(x, na.rm=na.rm),
             ymin = min(y, na.rm=na.rm),
             lower = quantile(y, lower_prob, na.rm=na.rm),
             middle = median(y, na.rm=TRUE),
             upper = quantile(y, upper_prob, na.rm=na.rm),
             ymax = max(y, na.rm=na.rm),
             y = median(y, na.rm=na.rm)
         )
         return (data)
     },
     required_aes = c('x', 'y')
)

GeomSkinnybox <- ggproto('GeomSkinnybox', Geom,
     required_aes = c('x', 'ymin', 'lower', 'middle', 'upper', 'ymax'),
     default_aes = aes(colour = 'black', linewidth = 0.5, fill = NA, alpha = NA, 
                       size = 2, linetype = 1, shape = 21, stroke = 1.5),
     draw_group = function(data, panel_params, coord, show_median, ...) {
         point <- transform(data)
         lower_line <- transform(data, x=x, xend=x, y=ymin, yend=lower)
         upper_line <- transform(data, x=x, xend=x, y=ymax, yend=upper)
       
         grid::gList(
             if (show_median) GeomPoint$draw_panel(point, panel_params, coord, ...),
             GeomSegment$draw_panel(lower_line, panel_params, coord, ...),
             GeomSegment$draw_panel(upper_line, panel_params, coord, ...)
         )
       
     }
)

geom_skinnybox <- function(mapping = NULL, data = NULL, stat = 'skinnybox', 
            position = 'identity', show.legend = NA, na.rm = TRUE, inherit.aes = TRUE, 
            show_median=TRUE, lower_prob = 0.25, upper_prob = 0.75, ...) {
        layer(
                data = data, 
                mapping = mapping,
                stat = stat,
                geom = GeomSkinnybox,
                position = position,
                show.legend = show.legend,
                inherit.aes = inherit.aes,
                params = list(na.rm=na.rm, show_median=show_median, 
                    lower_prob=lower_prob, upper_prob=upper_prob, ...)
        )
}

mpg %>% ggplot(aes(x=class, y=cty)) + geom_skinnybox()

mpg %>% ggplot(aes(x=class, y=cty)) + geom_skinnybox(lower_prob=0.1, upper_prob=0.9)

mpg %>% ggplot(aes(x=class, y=cty)) + geom_skinnybox(show_median=FALSE)

在ggplot2: Elegant Graphics for Data Analysis (3e)和官方文档中，你能见到的示例大多使用 draw_panel而不是 draw_group绘制。然而，draw_panel无法识别 group刻度，也无法很方便地传参（本例换用 draw_panel在 ggplot v3.4.1版本中传参报错），建议优先使用 draw_group。

xy轴翻转

以 geom_histogram直方图为例，x轴对应 data中的数据，y轴是后期计算的频数，此时 geom_histogram(aes(x=value))即可绘制。有时，我们希望 y轴对应 data，那么只需 geom_histogram(aes(y=value))。

再以 geom_boxplot箱线图为例，y轴对应 data中的数据，x轴要么没有、要么是分类变量，此时 geom_boxplot(aes(y=value))即可绘制。有时，我们希望 x轴对应 data，那么只需 geom_boxplot(aes(x=value))。

然而，方便的xy翻转并非理所当然。回想之前 StatSkinnybox的 compute_group中，我们对 y做了一系列计算，获取 ymin, ymax, lower等，仅仅更改 mapping并不能让这些计算自动在 x上进行。你可以尝试为 geom_skinnybox映射连续变量到 x轴，这只会生成不完整的图形。

也就是说，geom_histogram内含的统计变换StatBin在 x上操作，映射 y时需要额外处理；geom_boxplot内含的统计变换StatBoxplot在 y上操作，映射 x时需要额外处理。

ggplot早期的解决方案是原样绘图，依赖 coord_flip()实现 xy翻转。现在的主流方案是通过 has_flipped_aes() 检测是否需要翻转，如果需要，将 x,xmin,xmax,xend等变量通过 flip_data()重命名为 y系列，统计变换之后再翻回（对 y亦然）。在绘制几何元素前，可能也需要翻转保证图形参数正确。

从 compute_group返回的数据必须翻回原样，因为 ggplot据此检测需要显示的 x,y范围。也需要修改 GeomXXX的 required_aes，以兼容两个方向的 data。

StatXXX <- ggproto(...,
    setup_params = function(self, data, params) {
        # 判断是否需要翻转
        params$flipped_aes <- has_flipped_aes(data, params, ...)
        return (params)
    },
    compute_group = function(..., flipped_aes) {
        # 如果flipped_aes=TRUE, 翻转后一系列统计变换
        data <- flip_data(data, flipped_aes)
        ...
        data$flipped_aes <- flipped_aes
        # 翻回
        data <- flip_data(data, flipped_aes)
        return (data)
    },
    ...
)

GeomXXX <- ggproto(...,
    # 设置兼容
    required_aes = c('x|y', 'ymin|xmin', 'ymax|xmax'),
    setup_params = StatXXX$setup_params,
    ...
)

那么，has_flipped_aes()在什么情况下会判定需要翻转呢？根据源码，有以下几种：

1. data中有 flipped_aes列，且值为 TRUE
2. 参数传入 orientation='y'。这里似乎默认 orientation='x'为正常情况，然而是否翻转要看 StatXXX中 compute_group方法，个人认为 has_flipped_aes()的参数名与作用并不完全匹配
3. 仅映射 x，且 main_is_orthogonal为 TRUE；仅映射 y，且 main_is_orthogonal为 FALSE
4. 映射了 xmin, xmax，且 range_is_orthogonal为 TRUE；映射了 ymin, ymax，且 range_is_orthogonal为 FALSE
5. y为连续变量，且 main_is_continuous为 TRUE；y为离散变量，且 main_is_continuous为 FALSE

至此，我们可以修改 geom_skinnybox()，以支持 xy翻转

StatSkinnybox <- ggproto('StatSkinnybox', Stat, 
  setup_params = function(self, data, params) {
    params$flipped_aes <- ggplot2::has_flipped_aes(data, params, main_is_orthogonal = TRUE,
                                          group_has_equal = TRUE,
                                          main_is_optional = TRUE)
    return (params)
    },
     compute_group = function(data, scales, na.rm, lower_prob, upper_prob, flipped_aes) {
         data <- ggplot2::flip_data(data, flipped_aes)
       
         data <- dplyr::summarise(data,
             x = median(x, na.rm=na.rm),
             ymin = min(y, na.rm=na.rm),
             lower = quantile(y, lower_prob, na.rm=na.rm),
             middle = median(y, na.rm=TRUE),
             upper = quantile(y, upper_prob, na.rm=na.rm),
             ymax = max(y, na.rm=na.rm),
             y = median(y, na.rm=na.rm)
         )
         data$flipped_aes <- flipped_aes
         data <- ggplot2::flip_data(data, flipped_aes)

         return (data)
     },
     required_aes = c('x', 'y')
)

GeomSkinnybox <- ggproto('GeomSkinnybox', Geom,
     required_aes = c('y|x', 'ymin|xmin', 'lower|xlower', 'middle|xmiddle', 'upper|xupper', 'ymax|xmax'),
     setup_params = StatSkinnybox$setup_params,
     default_aes = aes(colour = 'black', linewidth = 0.5, fill = NA, alpha = NA, 
                       size = 2, linetype = 1, shape = 21, stroke = 1.5),
     draw_group = function(data, panel_params, coord, show_median, flipped_aes, ...) {
         data <- ggplot2::flip_data(data, flipped_aes)
         point <- ggplot2::flip_data(transform(data), flipped_aes)
         lower_line <-  ggplot2::flip_data(transform(data, x=x, xend=x, y=ymin, yend=lower), flipped_aes)
         upper_line <- ggplot2::flip_data(transform(data, x=x, xend=x, y=ymax, yend=upper), flipped_aes)
       
         grid::gList(
             if (show_median) GeomPoint$draw_panel(point, panel_params, coord, ...),
             GeomSegment$draw_panel(lower_line, panel_params, coord, ...),
             GeomSegment$draw_panel(upper_line, panel_params, coord, ...)
         )
     }
)

geom_skinnybox <- function(mapping = NULL, data = NULL, stat = 'skinnybox', 
            position = 'identity', show.legend = NA, na.rm = TRUE, inherit.aes = TRUE, 
            show_median=TRUE, lower_prob = 0.25, upper_prob = 0.75, ...) {
        layer(
                data = data, 
                mapping = mapping,
                stat = stat,
                geom = GeomSkinnybox,
                position = position,
                show.legend = show.legend,
                inherit.aes = inherit.aes,
                params = list(na.rm=na.rm, show_median=show_median, 
                    lower_prob=lower_prob, upper_prob=upper_prob, ...)
        )
}

mpg %>% ggplot(aes(y=class, x=cty)) + geom_skinnybox()

其他

在 jupyterIDE下调用自定义 geom_xxx()函数绘图，有时会遇到如下警告，不影响结果但有些烦人：

Warning message in geom2trace.default(dots[[1L]][[1L]], dots[[2L]][[1L]], dots[[3L]][[1L]]):
“geom_GeomDesvalue() has yet to be implemented in plotly.
  If you'd like to see this geom implemented,
  Please open an issue with your example code at
  https://github.com/ropensci/plotly/issues”

geom2trace()函数的作用是将 ggplot对象转换为 plotly可交互图形，这个警告的意思是 plotly包（理所应当地）还没有为我们自建的 Geom对象创建合适的 geom2trace()函数，只好调用默认的 geom2trace.default()。鉴于我们没用到 plotly包，可能是 jupyter内核后台调用了。在 CMD下就不会出现该警告。

解决办法也很简单，定义一个专门的 geom2trace()处理自建的 Geom对象即可。如果后续有转 plotly的需求，还可以进一步完善该函数。

geom2trace.GeomDesvalue <- function(data, params, plot) {}

以上就是 ggplot代码复用三大技巧的所有内容。当你掌握这些技巧，同时了解如何创建R包时，你将再也不担心代码整理、版本控制等问题。

祝玩的开心！