如何制作具有多个几何形状的自定义 ggplot2 几何图形

Question

我一直在阅读vignette on extending ggplot2，但我对如何制作一个可以为绘图添加多个几何图形的几何图形有点困惑。 ggplot2 几何图形中已经存在多个几何图形，例如，我们有 geom_contour（多条路径）和 geom_boxplot（多条路径和点）之类的东西。但我不太明白如何将它们扩展到新的几何图形中。

假设我正在尝试制作一个geom_manythings，它将通过在单个数据集上进行计算来绘制两个多边形和一个点。一个多边形将是所有点的凸包，第二个多边形将是点子集的凸包，单个点将代表数据的中心。我希望所有这些都与一个 geom 的调用一起出现，而不是三个单独的调用，正如我们在这里看到的：

# example data set
set.seed(9)
n <- 1000
x <- data.frame(x = rnorm(n),
                y = rnorm(n))

# computations for the geometries 
# chull for all the points
hull <-  x[chull(x),]
# chull for all a subset of the points
subset_of_x <- x[x$x > 0 & x$y > 0 , ]
hull_of_subset <- subset_of_x[chull(subset_of_x), ]
# a point in the centre of the data
centre_point <- data.frame(x = mean(x$x), y = mean(x$y))

# plot
library(ggplot2)
ggplot(x, aes(x, y)) +
  geom_point() + 
  geom_polygon(data = x[chull(x),], alpha = 0.1) +
  geom_polygon(data = hull_of_subset, alpha = 0.3) +
  geom_point(data = centre_point, colour = "green", size = 3)

我想要一个geom_manythings 来替换上面代码中的三个geom_*。

为了制作自定义几何图形，我从 geom_tufteboxplot 和 geom_boxplot 中的代码作为模板开始，以及“扩展 ggplot2”小插图：

library(ggplot2)
library(proto)

GeomManythings <- ggproto(
  "GeomManythings",
  GeomPolygon,
  setup_data = function(self, data, params) {
    data <- ggproto_parent(GeomPolygon, self)$setup_data(data, params)
    data
  },

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

    common <- data.frame(
      colour = data$colour,
      size = data$size,
      linetype = data$linetype,
      fill = alpha(data$fill, data$alpha),
      group = data$group,
      stringsAsFactors = FALSE
    )

    # custom bits...

    # polygon hull for all points
    hull <-  data[chull(data), ]
    hull_df <- data.frame(x = hull$x, 
                          y = hull$y, 
                          common, 
                          stringsAsFactors = FALSE)
    hull_grob <-
      GeomPolygon$draw_panel(hull_df, panel_scales, coord)

    # polygon hull for subset
    subset_of_x <-
      data[data$x > 0 & data$y > 0 ,]
    hull_of_subset <-
      subset_of_x[chull(subset_of_x),]
    hull_of_subset_df <- data.frame(x = hull_of_subset$x, 
                                    y = hull_of_subset$y, 
                                    common, 
                                    stringsAsFactors = FALSE)
    hull_of_subset_grob <-
      GeomPolygon$draw_panel(hull_of_subset_df, panel_scales, coord)

    # point for centre point
    centre_point <-
      data.frame(x = mean(coords$x), 
                 y = coords(data$y),
                 common, 
                 stringsAsFactors = FALSE)

    centre_point_grob <-
      GeomPoint$draw_panel(centre_point, panel_scales, coord)

    # end of custom bits

    ggname("geom_mypolygon",
           grobTree(hull_grob,
                    hull_of_subset_grob,
                    centre_point_grob))


  },

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

  draw_key = draw_key_polygon,

  default_aes = aes(
    colour = "grey20",
    fill = "grey20",
    size = 0.5,
    linetype = 1,
    alpha = 1,
  )
)

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

但是很明显这个geom有很多地方不对劲，我一定是遗漏了一些基本的细节......

ggplot(x, aes(x, y)) +
  geom_point() +
  geom_manythings()

如何编写这个 geom 以获得所需的结果？

Answer 1

你的代码有很多问题，所以我建议你先尝试一个简化的案例。特别是，chull 计算是有问题的。试试这个，

library(ggplot2)
library(proto)
library(grid)

GeomManythings <- ggproto(
  "GeomManythings",
  Geom,
  setup_data = function(self, data, params) {
    data <- ggproto_parent(Geom, self)$setup_data(data, params)
    data
  },

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


    # polygon hull for all points
    hull_df <-  data[chull(data[,c("x", "y")]), ]

    hull_grob <-
      GeomPolygon$draw_panel(hull_df, panel_scales, coord)

    # polygon hull for subset
    subset_of_x <-
      data[data$x > 0 & data$y > 0 ,]
    hull_of_subset_df <-subset_of_x[chull(subset_of_x[,c("x", "y")]),]
    hull_of_subset_df$fill <- "red" # testing
    hull_of_subset_grob <-  GeomPolygon$draw_panel(hull_of_subset_df, panel_scales, coord)

    coords <- coord$transform(data, panel_scales)     

    pg <- pointsGrob(x=mean(coords$x), y=mean(coords$y), 
                     default.units = "npc", gp=gpar(col="green", cex=3))

    ggplot2:::ggname("geom_mypolygon",
                     grobTree(hull_grob,
                              hull_of_subset_grob, pg))


  },


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

  draw_key = draw_key_polygon,

  default_aes = aes(
    colour = "grey20",
    fill = "grey50",
    size = 0.5,
    linetype = 1,
    alpha = 0.5
  )
)

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


set.seed(9)
n <- 20
d <- data.frame(x = rnorm(n),
                y = rnorm(n))

ggplot(d, aes(x, y)) +
  geom_manythings()+
  geom_point() 

（免责声明：我已经 5 年没有尝试过写 geom 了，所以我不知道现在它是如何工作的）