使用自定义几何为SF对象扩展ggplot2

Question

我想创建一个新的几何ggplot描述在这里，同时它与简单要素对象适应交易。

例如，让我们做同样的练习，绘制一组点的凸包。因此，我编写了一个新geom_envelope()函数，该函数借用了元素，geom_sf()并编写了一个相应的GeomEnvelope ggproto对象，该对象执行了覆盖该draw_group()方法的计算（因为我想要一个完整的点集用于单个多边形）。

但是，由于我无法绘制多边形，因此我必须缺少一些东西。我已经尝试了一段时间，但还是出现错误或没有任何内容绘制。

library(sf); library(ggplot2); library(dplyr)

Npts <- 10
pts <- matrix(runif(2*Npts), ncol = 2) %>% 
  st_multipoint() %>% 
  st_sfc() %>% 
  st_cast("POINT") %>% 
  st_sf()

GeomEnvelope <- ggproto(
  "GeomEnvelope", GeomSf,

  required_aes = "geometry",

  default_aes = aes(
    shape = NULL,
    colour = "grey20",
    fill = "white",
    size = NULL,
    linetype = 1,
    alpha = 0.5,
    stroke = 0.5
  ),

  draw_key = draw_key_polygon,

  draw_group = function(data, panel_params, coord) {
    n <- nrow(data)
    if (n <= 2) return(grid::nullGrob())

    gp <- gpar(
      colour = data$colour,
      size = data$size,
      linetype = data$linetype,
      fill = alpha(data$fill, data$alpha),
      group = data$group,
      stringsAsFactors = FALSE
    )

    geometry <- sf::st_convex_hull(st_combine(sf::st_as_sf(data)))

    sf::st_as_grob(geometry, pch = data$shape, gp = gp)

  }
)


geom_envelope <- function(
  mapping = aes(),
  data = NULL,
  position = "identity",
  na.rm = FALSE,
  show.legend = NA,
  inherit.aes = TRUE,
  ...) {

  if (!is.null(data) && ggplot2:::is_sf(data)) {
    geometry_col <- attr(data, "sf_column")
  }
  else {
    geometry_col <- "geometry"
  }
  if (is.null(mapping$geometry)) {
    mapping$geometry <- as.name(geometry_col)
  }
  c(
    layer(
      geom = GeomEnvelope,
      data = data,
      mapping = mapping,
      stat = "identity",
      position = position,
      show.legend = if (is.character(show.legend))
        TRUE
      else
        show.legend,
      inherit.aes = inherit.aes,
      params = list(
        na.rm = na.rm,
        legend = if (is.character(show.legend))
          show.legend
        else
          "polygon",
        ...
      )
    ),
    coord_sf(default = TRUE)
  )
}

ggplot(pts) + geom_sf() + geom_envelope() + theme_bw()

^{由reprex软件包（v0.2.1）创建于2019-04-23}

Answer 1

如果这是您的实际用例（而不是它的简化示例），那么我想说的是，您要寻找的基本部分是自定义Stat而不是自定义Geom。数据计算/操作应在前者内进行。

（作为参考，我通常查看GeomBoxplot/ 中的代码StatBoxplot以弄清楚应该在哪里发生，因为该用例包括大量的分位数/离群值计算，以及接受各种美学映射的不同grob元素的组合。）

具有随机种子的数据可重复性：

set.seed(123)

pts <- matrix(runif(2*Npts), ncol = 2) %>% 
  st_multipoint() %>% 
  st_sfc() %>% 
  st_cast("POINT") %>% 
  st_sf()

基本示范

以下代码StatEnvelope将数据集传递到相关的geom层，并将每组内的几何值集合（如果未指定分组美观，则将整个数据集视为一组）转换为凸包：

StatEnvelope <- ggproto(
  "StatEnvelope", Stat,
  required_aes = "geometry",
  compute_group = function(data, scales) {
    if(nrow(data) <= 2) return (NULL)
    data %>%
      group_by_at(vars(-geometry)) %>%
      summarise(geometry = sf::st_convex_hull(sf::st_combine(geometry))) %>%
      ungroup()
  }
)

ggplot(pts) + 
  geom_sf() +
  geom_sf(stat = StatEnvelope, 
          alpha = 0.5, color = "grey20", fill = "white", size = 0.5) +
  theme_bw()

升级

上面的方法，使用现有的geom_sf，在创建信封方面做得很完美。如果我们要指定一些默认的美学参数，而不是在的每个实例中重复geom_sf，我们仍然不需要定义新的Geom。修改现有功能的功能geom_sf就可以了。

geom_envelope <- function(...){
  suppressWarnings(geom_sf(stat = StatEnvelope, 
                           ..., # any aesthetic argument specified in the function 
                                # will take precedence over the default arguments
                                # below, with suppressWarning to mute warnings on
                                # any duplicated aesthetics
                           alpha = 0.5, color = "grey20", fill = "white", size = 0.5))
}

# outputs same plot as before
ggplot(pts) + 
  geom_sf() +
  geom_envelope() +
  theme_bw()

# with different aesthetic specifications for demonstration
ggplot(pts) + 
  geom_sf() +
  geom_envelope(alpha = 0.1, colour = "brown", fill = "yellow", size = 3) +
  theme_bw()

问题中发布的代码的说明

当我弄乱自定义的ggproto对象时，我喜欢使用的一个有用技巧是在我修改的每个函数中插入打印语句，例如"setting up parameters"，或"drawing panel, step 3"等。这使我对幕后发生的事情有了一个很好的了解，并进行跟踪当函数（不可避免地）在第一次尝试/第二次尝试/.../第n次尝试返回错误时哪里出错了。

在这种情况下，如果我们插入print("draw group")之初GeomEnvelope的draw_group功能运行前ggplot(pts) + geom_sf() + geom_envelope() + theme_bw()，我们将看到没有在控制台打印任何消息。换句话说，该draw_group函数从未被调用过，因此其中定义的任何数据操作都不会影响输出。

中有几个draw_*函数Geom*，当我们要进行修改时可能会造成混淆。从的代码中Geom，我们可以看到层次结构如下：

1. draw_layer（包括do.call(self$draw_panel, args)一行）
2. draw_panel（包括self$draw_group(group, panel_params, coord, ...)一行）
3. draw_group（尚未实现Geom）。

所以draw_layer触发draw_panel，然后draw_panel触发draw_group。（镜像此，在Stat，compute_layer触发器compute_panel和compute_panel触发compute_group。）

GeomSf，其继承Geom（代码这里），覆盖Geom的draw_panel带的代码块，返回一个功能sf_grob(...)，和不触发draw_group。

因此，当GeomEnvelope继承GeomSf的draw_panel功能，没有在其draw_group功能件事情影响。绘图中绘制的内容取决于draw_panel，geom_envelope问题中的图层执行的工作基本上与geom_sf单独绘制每个单独点的任务相同。如果删除/注释掉geom_sf图层，您将看到相同的点；仅使用color =“ grey20”，alpha = 0.5等（如的中所指定GeomSf）default_aes。

（注意：fill = "white"未使用，因为geom_sf默认GeomPoint为点数据的默认美感，这意味着它会为其点形状继承GeomPoint的pch = 19，并绘制不受任何填充值影响的实心圆。）