如何制作具有多个几何的自定义ggplot2 geom

Question

我一直在阅读vignette on extending ggplot2，但我有点不知道如何制作一个可以在绘图中添加多个几何图形的geom。 ggplot2 geoms中已存在多个几何，例如，我们有geom_contour（多个路径）和geom_boxplot（多个路径和点）之类的东西。但我不太清楚如何将它们扩展到新的geoms。

假设我正在尝试制作一个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，我开始使用geom_tufteboxplot和geom_boxplot中的代码作为模板，以及'extends 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

您的代码中存在相当多的问题，因此我建议您首先尝试使用简化的案例。特别是，船体计算存在问题。试试这个，

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，所以我现在不知道它是如何工作的）