构面时未显示ggplot2自定义统计信息

Question

我试图写一个自定义stat_*的ggplot2，在这里我想用瓷砖颜色的2D黄土表面。当我从扩展指南开始时，我可以像他们一样编写stat_chull：

stat_chull = function(mapping = NULL, data = NULL, geom = "polygon",
                       position = "identity", na.rm = FALSE, show.legend = NA, 
                       inherit.aes = TRUE, ...) {

  chull = ggproto("chull", Stat,
    compute_group = function(data, scales) {
      data[chull(data$x, data$y), , drop = FALSE]
    },
    required_aes = c("x", "y")
  )

  layer(
    stat = chull, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

这适用于简单的调用和构面包装：

ggplot(mpg, aes(x=displ, y=hwy)) + 
  geom_point() + 
  stat_chull()
# optionally + facet_wrap(~ class)

当编写我的代码时stat_loess2d，我还可以可视化所有类或单个类：

stat_loess2d = function(mapping = NULL, data = NULL, geom = "tile",
                       position = "identity", na.rm = FALSE, show.legend = NA, 
                       inherit.aes = TRUE, ...) {

  loess2d = ggproto("loess2d", Stat,
    compute_group = function(data, scales) {
      dens = MASS::kde2d(data$x, data$y)
      lsurf = loess(fill ~ x + y, data=data)
      df = data.frame(x = rep(dens$x, length(dens$y)),
                      y = rep(dens$y, each=length(dens$x)),
                      dens = c(dens$z))
      df$fill = predict(lsurf, newdata=df[c("x", "y")])
      df
    },
    required_aes = c("x", "y", "fill")
  )

  layer(
    stat = loess2d, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

ggplot(mpg, aes(x=displ, y=hwy, fill=year)) + 
  geom_point(aes(color=year)) + 
  stat_loess2d()

ggplot(mpg[mpg$class == "compact",], aes(x=displ, y=hwy, fill=year)) + 
  geom_point(aes(color=year)) + 
  stat_loess2d()

但是，当我尝试上述方面时，不再显示图块：

ggplot(mpg, aes(x=displ, y=hwy, fill=year)) + 
  geom_point(aes(color=year)) + 
  stat_loess2d() +
  facet_wrap(~ class)

有人可以告诉我我在做什么错吗？

Answer 1

解释

geom_tile我在这里看到的主要问题实际上超出了您所做的工作，并且与当特定的 x / y 轴值显着不同时如何处理不同方面的图块创建有关。一个较旧的问题演示了类似的现象：geom_tile单独处理每个方面的数据效果很好，但是将它们放在一起，图块会缩小以匹配不同方面值之间的最小差异。这会在绘图层中留下大量的空白，并且通常会随着每个额外的面而逐渐变得更糟，直到图块本身变得几乎不可见。

为了解决这个问题，我会在每个方面的密度/黄土计算之后添加一个数据处理步骤，以标准化所有方面的 x 和 y 值的范围。

如果您不太熟悉compute_layer、compute_panel和 之间的关系，请进行一些详细说明compute_group（当我开始摆弄 ggproto 对象时，我当然不是很熟悉......）：

• 本质上，所有对象都具有这三个功能来弥合给定数据帧（在本例中）与事物侧面接收到的内容Stat*之间的差距。mpgGeom*

• 在这三个函数中，compute_layer是顶级函数，通常会触发compute_panel为每个方面/面板计算单独的数据帧（导出函数中使用的术语是facet，但底层包代码指的是与面板相同；我不是当然也知道为什么）。依次触发compute_panel为每个组计算单独的数据帧（由///等美学参数compute_group定义）。groupcolourfill

• 结果compute_group返回compute_panel并组合成一个数据帧。同样，compute_layer从每个方面接收一个数据帧compute_panel，并将它们再次组合在一起。然后将组合的数据帧传递到Geom*绘图。

（上面是顶层 中定义的通用设置Stat。Stat*继承自的其他对象Stat可能会覆盖任何步骤中的行为。例如，StatIdentitys 按compute_layer原样返回原始数据帧，根本不触发compute_panel/ compute_group，因为对于未更改的数据无需这样做。）

对于此用例，我们可以在从/compute_layer返回结果并将结果组合在一起后修改 中的代码，以将与每个方面关联的值插入到公共容器中。因为普通的垃圾箱 = 漂亮的大瓷砖，中间没有空白。compute_panelcompute_group

修改

以下是我编写loess2dggproto 对象的方式，以及 的附加定义compute_layer：

loess2d = ggproto("loess2d", Stat,
                  compute_group = function(data, scales) {
                    dens = MASS::kde2d(data$x, data$y)
                    lsurf = loess(fill ~ x + y, data=data)
                    df = data.frame(x = rep(dens$x, length(dens$y)),
                                    y = rep(dens$y, each=length(dens$x)),
                                    dens = c(dens$z))
                    df$fill = predict(lsurf, newdata=df[c("x", "y")])
                    df
                  },
                  compute_layer = function(self, data, params, layout) {
                    # no change from Stat$compute_layer in this chunk, except
                    # for liberal usage of `ggplot2:::` to utilise un-exported
                    # functions from the package
                    ggplot2:::check_required_aesthetics(self$required_aes, 
                                                        c(names(data), names(params)), 
                                                        ggplot2:::snake_class(self))
                    data <- remove_missing(data, params$na.rm, 
                                           c(self$required_aes, self$non_missing_aes), 
                                           ggplot2:::snake_class(self),
                                           finite = TRUE)
                    params <- params[intersect(names(params), self$parameters())]
                    args <- c(list(data = quote(data), scales = quote(scales)), params)
                    df <- plyr::ddply(data, "PANEL", function(data) {
                      scales <- layout$get_scales(data$PANEL[1])
                      tryCatch(do.call(self$compute_panel, args), 
                               error = function(e) {
                                 warning("Computation failed in `", ggplot2:::snake_class(self), 
                                         "()`:\n", e$message, call. = FALSE)
                                 data.frame()
                               })
                    })

                    # define common x/y grid range across all panels
                    # (length = 25 chosen to match the default value for n in MASS::kde2d)
                    x.range <- seq(min(df$x), max(df$x), length = 25)
                    y.range <- seq(min(df$y), max(df$y), length = 25)

                    # interpolate each panel's data to a common grid,
                    # with NA values for regions where each panel doesn't
                    # have data (this can be changed via the extrap
                    # parameter in akima::interp, but I think  
                    # extrapolating may create misleading visuals)
                    df <- df %>% 
                      tidyr::nest(-PANEL) %>%
                      mutate(data = purrr::map(data, 
                                               ~akima::interp(x = .x$x, y = .x$y, z = .x$fill,
                                                              xo = x.range, yo = y.range,
                                                              nx = 25, ny = 25) %>%
                                                 akima::interp2xyz(data.frame = TRUE) %>%
                                                 rename(fill = z))) %>%
                      tidyr::unnest()

                    return(df)
                  },
                  required_aes = c("x", "y", "fill")
)

用法：

ggplot(mpg,
       aes(x=displ, y=hwy, fill=year)) + 
  stat_loess2d() +
  facet_wrap(~ class)
# this does trigger warnings (not errors) because some of the facets contain
# really very few observations. if we filter for facets with more rows of data
# in the original dataset, this wouldn't be an issue

ggplot(mpg %>% filter(!class %in% c("2seater", "minivan")),
       aes(x=displ, y=hwy, fill=year)) + 
  stat_loess2d() +
  facet_wrap(~ class)
# no warnings triggered