使用 sf 对象的自定义几何扩展 ggplot2

Question

我正尝试按照 here 的描述为 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 package (v0.2.1)}

于 2019-04-23 创建

Answer 1

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

（作为参考，我通常会查看 GeomBoxplot / StatBoxplot 中的代码来弄清楚事情应该发生在哪里，因为该用例包括一堆对分位数/异常值的计算，以及不同的组合抢夺接受各种美学映射的元素。）

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

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"，等等。这让我可以很好地了解幕后发生的事情，并在函数（不可避免地）returns 出现错误时跟踪出错的地方第 1 / 2 / ... / 第 n 次尝试。

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

Geom*里面有几个draw_*函数，我们想修改的时候会很迷惑。从code for Geom可以看出层次结构如下：

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

因此 draw_layer 触发 draw_panel，而 draw_panel 触发 draw_group。（反映这一点，在 Stat 中，compute_layer 触发 compute_panel，compute_panel 触发 compute_group。）

GeomSf 继承自 Geom（代码 here），用一段代码覆盖 Geom 的 draw_panel 函数 returns 一个 sf_grob(...)，并且不会触发 draw_group.

因此，当 GeomEnvelope 继承了 GeomSf 的 draw_panel 函数时，其 draw_group 函数中的任何内容都无关紧要。图中绘制的内容取决于 draw_panel，问题中的 geom_envelope 层执行与 geom_sf 基本相同的任务，分别绘制每个单独的点。如果您删除/注释掉 geom_sf 层，您会看到相同的点；仅使用颜色 = "grey20"、alpha = 0.5 等，如 GeomSf 的 default_aes.

中指定

(注意：fill = "white"没有使用，因为geom_sf默认为GeomPoint默认的点数据美学，也就是说它继承了GeomPoint的pch = 19为其点形状，并绘制一个不受任何填充值影响的实心圆。）

使用 sf 对象的自定义几何扩展 ggplot2

Extending ggplot2 with a custom geometry for sf objects

r

ggplot2

sf

ggproto

基本演示

升级

问题中发布的代码的解释