自定义 `geom_` 有两种不同的绘图风格

Question

我的目标是编写一个自定义的geom_ 方法来计算和绘制，例如，置信区间，这些应该绘制为多边形或线条。现在的问题是，在哪里检查应该绘制哪种“样式”？

到目前为止，我已经尝试了三种不同的方法，

• (i) 为线和多边形样式的绘图编写两个不同的geom_/stat_，
• (ii) 编写一个使用自定义GeomMethod 的geom_/stat_，
• (iii) 编写一个geom_/stat_，它使用GeomPolygon 或GeomLine。

在我看来，总结一下

• (i) 或多或少直截了当，但只是绕过了问题，
• (ii) 在您使用 GeomPath$draw_panel() 或 GeomPolygon$draw_panel() 时起作用，具体取决于额外参数 style。但是在这里我无法设置default_aes，这也取决于额外的参数style。比较答案here。
• (iii) 在调用 geom_ 时有效，但在调用 stat_ 时失败，因为 ggplot2 中的名称匹配失败。请参阅下面的最小示例。

设置方法（iii）的方法：

geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
                            position = "identity", na.rm = FALSE,
                            show.legend = NA, inherit.aes = TRUE,
                            style = c("polygon", "line"), ...) {
  style <- match.arg(style)

  ggplot2::layer(
    geom = if (style == "line") GeomPath else GeomPolygon,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      style = style,
      ...
    )
  )
}

stat_my_confint <- function(mapping = NULL, data = NULL, geom = "my_confint",
                            position = "identity", na.rm = FALSE,
                            show.legend = NA, inherit.aes = TRUE,
                            style = c("polygon", "line"), ...) {

  style <- match.arg(style)

  ggplot2::layer(
    geom = geom, 
    stat = StatMyConfint,
    data = data,
    mapping = mapping,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      style = style,
      ...
    )
  )
}

StatMyConfint <- ggplot2::ggproto("StatMyConfint", ggplot2::Stat,
  compute_group = function(data, scales, style) {
    if (style == "polygon") {
      nd <- data.frame(
        x = c(data$x, rev(data$x)),
        y = c(data$y - 1, rev(data$y) + 1)
      )
      nd
    } else {
      nd <- data.frame(
        x = rep(data$x, 2),
        y = c(data$y - 1, data$y + 1),
        group = c(rep(1, 5), rep(2, 5))
      )
      nd
    }
  },
  
  required_aes = c("x", "y")
)

尝试方法（iii）的方法：

library("ggplot2")

d <- data.frame(
  x = seq(1, 5),
  y = seq(1, 5)
)

ggplot(d, aes(x = x, y = y)) + geom_line() + geom_my_confint(style = "polygon", alpha = 0.2)
ggplot(d, aes(x = x, y = y)) + geom_line() + geom_my_confint(style = "line", linetype = 2)

到目前为止效果很好。但是在调用stat_ 时，ggplot2:::check_subclass 出现错误，因为没有GeomMyConfint 方法。

ggplot(d, aes(x = x, y = y)) + geom_line() + stat_my_confint()
# Error: Can't find `geom` called 'my_confint'

对替代方法有任何解决方案或建议吗？

Answer 1

以下不是很优雅，但似乎有效。让我们定义以下构造函数，其中geom 设置为GeomMyConfint，我们将在下面进一步定义。

geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
                            position = "identity", na.rm = FALSE,
                            show.legend = NA, inherit.aes = TRUE,
                            style = c("polygon", "line"), ...) {
  style <- match.arg(style)
  
  ggplot2::layer(
    geom = GeomMyConfint,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      style = style,
      ...
    )
  )
}

下面是配对的 ggproto 类。我修改了use_defaults 方法，用一些文本替换了默认颜色。然后，draw_panel() 方法会根据 style 参数选择实际的默认值来替换我们之前插入的文本。

GeomMyConfint <- ggproto(
  "GeomMyConfint", GeomPolygon,

  # Tag colour if it has been defaulted
  use_defaults = function(self, data, params = list(), modifiers = aes()) {
    has_colour <- "colour" %in% names(data) || "colour" %in% names(params)
    data <- ggproto_parent(GeomPolygon, self)$use_defaults(
      data, params, modifiers
    )
    if (!has_colour) {
      data$colour <- "default_colour"
    }
    data
  },

  # Resolve colour defaults here
  draw_panel = function(
    data, panel_params, coord, 
    # Polygon arguments
    rule = "evenodd", 
    # Line arguments
    lineend = "butt", linejoin = "round", linemitre = 10, 
    na.rm = FALSE, arrow = NULL,
    # Switch argument
    style = "polygon") 
  {
    if (style == "polygon") {
      data$colour[data$colour == "default_colour"] <- NA
      GeomPolygon$draw_panel(data, panel_params, coord, rule)
    } else {
      data$colour[data$colour == "default_colour"] <- "black"
      GeomPath$draw_panel(data, panel_params, coord, 
                          arrow, lineend, linejoin, linemitre, na.rm)
    }
  }
)

然后使用示例中的其余功能。

更优雅的方法可能是使用 vctrs 包为易于识别的默认值定义自定义 S3 类，但我之前没有看到有人尝试使用 aes(colour = I("default_colour"))，所以你是除了这个单一的边缘情况之外可能是安全的。

Answer 2

根据@teunbrand 的回答以及geom_sf() 的实现方式，我想出了以下解决方案支持方法（ii）：

geom_my_confint <- function(mapping = NULL, data = NULL, stat = "my_confint",
                            position = "identity", na.rm = FALSE,
                            show.legend = NA, inherit.aes = TRUE,
                            type = c("polygon", "line"), ...) {
  type <- match.arg(type)

  ggplot2::layer(
    geom = GeomMyConfint,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      type = type,
      ...
    )
  )
}


GeomMyConfint <- ggplot2::ggproto("GeomMyConfint", ggplot2::Geom,

  ## Setting up all defaults needed for `GeomPolygon` and `GeomPath`
  default_aes = ggplot2::aes(
    colour = NA,
    fill = NA,
    size = NA,
    linetype = NA,
    alpha = NA,
    subgroup = NULL
  ),

  draw_panel = function(data, panel_params, coord,
                        rule = "evenodd", # polygon arguments
                        lineend = "butt", linejoin = "round", # line arguments
                        linemitre = 10, na.rm = FALSE, arrow = NULL, # line arguments
                        type = c("polygon", "line")) {
    type <- match.arg(type)

    ## Swap NAs in `default_aes` with own defaults 
    data <- my_modify_list(data, my_default_aesthetics(type), force = FALSE)

    if (type == "polygon") {
      GeomPolygon$draw_panel(data, panel_params, coord, rule)
    } else {
      GeomPath$draw_panel(data, panel_params, coord,
                          arrow, lineend, linejoin, linemitre, na.rm)
    }

  },

  draw_key = function(data, params, size) {
    ## Swap NAs in `default_aes` with own defaults 
    data <- my_modify_list(data, my_default_aesthetics(params$type), force = FALSE)
    if (params$type == "polygon") {
      draw_key_polygon(data, params, size)
    } else {
      draw_key_path(data, params, size)
    }
  }
)


## Helper function inspired by internal from `ggplot2` defined in `performance.R`
my_modify_list <- function(old, new, force = FALSE) {

  if (force) {
    for (i in names(new)) old[[i]] <- new[[i]]
  } else {
    for (i in names(new)) old[[i]] <- if (all(is.na(old[[i]]))) new[[i]] else old[[i]]
  }

  old
}


## Helper function inspired by internal from `ggplot2` defined in `geom-sf.R`
my_default_aesthetics <- function(type) {
  if (type == "line") {
    my_modify_list(GeomPath$default_aes, list(colour = "red", linetype = 2), force = TRUE)
  } else {
    my_modify_list(GeomPolygon$default_aes, list(fill = "red", alpha = 0.2), force = TRUE)
  }
}

我保持上面的stat_my_confint() 和StatMyConfint() 不变（根据geom_sf() 的命名，现在只有参数style 被称为type）：

stat_my_confint <- function(mapping = NULL, data = NULL, geom = "my_confint",
                            position = "identity", na.rm = FALSE,
                            show.legend = NA, inherit.aes = TRUE,
                            type = c("polygon", "line"), ...) {

  type <- match.arg(type)

  ggplot2::layer(
    geom = geom,
    stat = StatMyConfint,
    data = data,
    mapping = mapping,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      type = type,
      ...
    )
  )
}


StatMyConfint <- ggplot2::ggproto("StatMyConfint", ggplot2::Stat,
  compute_group = function(data, scales, type) {
    if (type == "polygon") {
      nd <- data.frame(
        x = c(data$x, rev(data$x)),
        y = c(data$y - 1, rev(data$y) + 1)
      )
      nd
    } else {
      nd <- data.frame(
        x = rep(data$x, 2),
        y = c(data$y - 1, data$y + 1),
        group = c(rep(1, 5), rep(2, 5))
      )
      nd
    }
  },

  required_aes = c("x", "y")
)

现在上面的例子可以正常工作了：

library("ggplot2")

d1 <- data.frame(
  x = seq(1, 5),
  y = seq(1, 5)
)

ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint()
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "line")
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "polygon", alpha = 0.8)
ggplot(d1, aes(x = x, y = y)) + geom_line() + geom_my_confint(type = "line", linetype = 4, colour = "red")


ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint()
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "line")
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "polygon", alpha = 0.8)
ggplot(d1, aes(x = x, y = y)) + geom_line() + stat_my_confint(type = "line", linetype = 4, colour = "red")

但是，如果您需要额外的解决方案仍然会失败，例如，通过外部分组变量设置多边形的fill 颜色：

d2 <- data.frame(
  x = rep(seq(1, 5), 2),
  y = rep(seq(1, 5), 2),
  z = factor(c(rep(1, 5), rep(2, 5)))
)

ggplot(d2, aes(x = x, y = y)) + geom_line() + geom_my_confint() + facet_wrap(.~z)
# no error

ggplot(d2, aes(x = x, y = y, fill = z)) + geom_line() + geom_my_confint() + facet_wrap(.~z)
# Error in grid.Call.graphics(C_setviewport, vp, TRUE) : 
#  non-finite location and/or size for viewport

所以仍然没有完美的答案。感谢帮助/扩展！

编辑：

如果在GeomMyConfint$default_aes() 中将size 参数设置为0.5，则该错误不再发生：

• 我不清楚为什么 - 任何人？！
• 在这里，这是可行的，因为我不会将默认的 size 更改为 GeomPolygon 或 GeomPath，否则会出现问题。
• 我没有发现更多错误（目前）。

改编代码：

GeomMyConfint <- ggplot2::ggproto("GeomMyConfint", ggplot2::Geom,

  ## Setting up all defaults needed for `GeomPolygon` and `GeomPath`
  default_aes = ggplot2::aes(
    colour = NA,
    fill = NA,
    size = 0.5,
    linetype = NA,
    alpha = NA,
    subgroup = NULL
  ),
  
  draw_panel = function(data, panel_params, coord,
                        rule = "evenodd", # polygon arguments
                        lineend = "butt", linejoin = "round", # line arguments
                        linemitre = 10, na.rm = FALSE, arrow = NULL, # line arguments
                        type = c("polygon", "line")) {
    type <- match.arg(type)
    
    ## Swap NAs in `default_aes` with own defaults 
    data <- my_modify_list(data, my_default_aesthetics(type), force = FALSE)
    
    if (type == "polygon") {
      GeomPolygon$draw_panel(data, panel_params, coord, rule)
    } else {
      GeomPath$draw_panel(data, panel_params, coord,
                          arrow, lineend, linejoin, linemitre, na.rm)
    }
    
  },
  
  draw_key = function(data, params, size) {
    ## Swap NAs in `default_aes` with own defaults 
    data <- my_modify_list(data, my_default_aesthetics(params$type), force = FALSE)
    if (params$type == "polygon") { 
      draw_key_polygon(data, params, size)
    } else {
      draw_key_path(data, params, size)
    }
  }
)

剧情：

ggplot(d2, aes(x = x, y = y, fill = z)) + geom_line() + geom_my_confint() + facet_wrap(.~z)