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

Question

我一直在阅读 vignette on extending ggplot2 ，但我对如何制作可以向绘图添加多个几何图形的单个几何图形有些困惑。 ggplot2 geoms 中已经存在多个几何图形，例如，我们有类似 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，所以我现在不知道它是如何工作的)