【问题标题】:Creating geom / stat from scratch从头开始创建 geom / stat
【发布时间】:2018-09-27 14:24:45
【问题描述】:

我不久前才开始使用 R,目前正在努力加强我的可视化技能。我想做的是用 mean diamonds 创建箱线图作为顶部的一层(参见下面链接中的图片)。我还没有找到任何可以做到这一点的函数,所以我想我必须自己创建它。

我希望做的是创建一个 geom 或 stat 来允许这样的事情工作:

ggplot(data, aes(...))) + 
   geom_boxplot(...) +
   geom_meanDiamonds(...)

我不知道从哪里开始构建这个新功能。我知道平均菱形需要哪些值(平均值和置信区间),但我不知道如何构建从 ggplot() 获取数据的 geom / stat,计算每个组的平均值和 CI,并绘制每个箱线图顶部的平均菱形。

我已经搜索了有关如何从头开始构建这些类型的函数的详细说明,但是,我还没有找到任何真正从底层开始的东西。如果有人能指出一些有用的指南,我将不胜感激。

谢谢!

【问题讨论】:

标签: r ggplot2 boxplot ggproto


【解决方案1】:

我目前正在学习自己编写 geom,所以这将是一个相当长且漫无边际的帖子,因为我通过我的思考过程,从 Stats 方面(计算这些多边形和线段应该在哪里)的几何图形。

免责声明:我不熟悉这种情节,谷歌也没有抛出很多权威指南。我对此处如何计算/使用置信区间的理解可能不正确。

第 0 步。了解 geom/stat 和层函数之间的关系。

geom_boxplotstat_boxplot 是层函数的示例。如果您将它们输入 R 控制台,您会看到它们(相对)较短,并且不包含用于计算箱线图的框/须的实际代码。相反,geom_boxplot 包含一行写着 geom = GeomBoxplot,而 stat_boxplot 包含一行写着 stat = StatBoxplot(转载如下)。

> stat_boxplot
function (mapping = NULL, data = NULL, geom = "boxplot", position = "dodge2", 
    ..., coef = 1.5, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) 
{
    layer(data = data, mapping = mapping, stat = StatBoxplot, 
        geom = geom, position = position, show.legend = show.legend, 
        inherit.aes = inherit.aes, params = list(na.rm = na.rm, 
            coef = coef, ...))
}

GeomBoxplotStatBoxplot 是 ggproto 对象。它们是魔法发生的地方。

第 1 步。识别ggproto()_inherit 参数是您的朋友。

不要重新发明轮子。由于我们想要创建与箱线图很好地重叠的东西,我们可以参考用于此的 Geom / Stat,并且只更改必要的内容。

StatMeanDiamonds <- ggproto(
  `_class` = "StatMeanDiamonds",
  `_inherit` = StatBoxplot,
  ... # add functions here to override those defined in StatBoxplot
)

GeomMeanDiamonds <- ggproto(
  `_class` = "GeomMeanDiamonds",
  `_inherit` = GeomBoxplot,
  ... # as above
)

第 2 步。修改统计数据。

在 StatBoxplot 中定义了 3 个函数:setup_datasetup_paramscompute_group。您可以参考 Github 上的代码(上面的链接)了解详细信息,或通过输入例如 StatBoxplot$compute_group 来查看它们。

compute_group 函数计算与每个组关联的所有 y 值(即每个唯一的 x 值)的 ymin/lower/middle/upper/ymax 值,用于绘制箱线图。我们可以用一个计算置信区间和平均值的方法来覆盖它:

# ci is added as a parameter, to allow the user to specify different confidence intervals
compute_group_new <- function(data, scales, width = NULL, 
                              ci = 0.95, na.rm = FALSE){
  a <- mean(data$y)
  s <- sd(data$y)
  n <- sum(!is.na(data$y))
  error <- qt(ci + (1-ci)/2, df = n-1) * s / sqrt(n)
  stats <- c("lower" = a - error, "mean" = a, "upper" = a + error)

  if(length(unique(data$x)) > 1) width <- diff(range(data$x)) * 0.9

  df <- as.data.frame(as.list(stats))

  df$x <- if(is.factor(data$x)) data$x[1] else mean(range(data$x))
  df$width <- width

  df
}

(可选)StatBoxplot 为用户提供了将weight 作为美学映射的条款。我们也可以通过替换:

  a <- mean(data$y)
  s <- sd(data$y)
  n <- sum(!is.na(data$y))

与:

  if(!is.null(data$weight)) {
    a <- Hmisc::wtd.mean(data$y, weights = data$weight)
    s <- sqrt(Hmisc::wtd.var(data$y, weights = data$weight))
    n <- sum(data$weight[!is.na(data$y) & !is.na(data$weight)])
  } else {
    a <- mean(data$y)
    s <- sd(data$y)
    n <- sum(!is.na(data$y))
  }

StatBoxplot 中的其他功能无需更改。所以我们可以定义 StatMeanDiamonds 如下:

StatMeanDiamonds <- ggproto(
  `_class` = "StatMeanDiamonds",
  `_inherit` = StatBoxplot,
  compute_group = compute_group_new
)

第 3 步。修改 Geom。

GeomBoxplot 有 3 个函数:setup_datadraw_groupdraw_key。它还包括default_aes()required_aes() 的定义。

由于我们更改了上游数据源(StatMeanDiamonds 生成的数据包含计算列“lower”/“mean”/“upper”,而 StatBoxplot 生成的数据将包含计算列“ymin”/ “lower”/“middle”/“upper”/“ymax”),请检查下游setup_data 功能是否也受到影响。 (在这种情况下,GeomBoxplot$setup_data 没有引用受影响的列,因此这里不需要更改。)

draw_group 函数获取由 StatMeanDiamonds 生成并由setup_data 设置的数据,并生成多个数据帧。 “common”包含所有几何图形共有的美学映射。 “diamond.df”表示有助于菱形多边形的映射,“segment.df”表示有助于平均水平线段的映射。然后将数据帧分别传递给 GeomPolygon 和 GeomSegment 的draw_panel 函数,以生成实际的多边形/线段。

draw_group_new = function(data, panel_params, coord,
                      varwidth = FALSE){
  common <- data.frame(colour = data$colour, 
                       size = data$size,
                       linetype = data$linetype, 
                       fill = alpha(data$fill, data$alpha),
                       group = data$group, 
                       stringsAsFactors = FALSE)
  diamond.df <- data.frame(x = c(data$x, data$xmax, data$x, data$xmin),
                           y = c(data$upper, data$mean, data$lower, data$mean),
                           alpha = data$alpha,
                           common,
                           stringsAsFactors = FALSE)
  segment.df <- data.frame(x = data$xmin, xend = data$xmax,
                           y = data$mean, yend = data$mean,
                           alpha = NA,
                           common,
                           stringsAsFactors = FALSE)
  ggplot2:::ggname("geom_meanDiamonds",
                   grid::grobTree(
                     GeomPolygon$draw_panel(diamond.df, panel_params, coord),
                     GeomSegment$draw_panel(segment.df, panel_params, coord)
                   ))
}

draw_key 函数用于在需要时为该层创建图例。由于 GeoMMeanDiamonds 继承自 GeomBoxplot,默认为 draw_key = draw_key_boxplot,我们没有必须更改它。保持不变不会破坏代码。不过,我认为像draw_key_polygon 这样更简单的图例看起来不会那么杂乱。

GeomBoxplot 的 default_aes 规格看起来不错。但我们需要更改required_aes,因为我们期望从 StatMeanDiamonds 获得的数据不同(“lower”/“mean”/“upper”而不是“ymin”/“lower”/“middle”/“upper”/ "ymax")。

我们现在准备好定义 GeoMMeanDiamonds:

GeomMeanDiamonds <- ggproto(
  "GeomMeanDiamonds",
  GeomBoxplot,
  draw_group = draw_group_new,
  draw_key = draw_key_polygon,
  required_aes = c("x", "lower", "upper", "mean")
)

第 4 步。定义图层功能。

这是无聊的部分。我直接从geom_boxplot/stat_boxplot复制,删除geom_meanDiamonds中所有异常值的引用,更改为geom = GeomMeanDiamonds/stat = StatMeanDiamonds,并将ci = 0.95添加到stat_meanDiamonds

geom_meanDiamonds <- function(mapping = NULL, data = NULL,
                              stat = "meanDiamonds", position = "dodge2",
                              ..., varwidth = FALSE, na.rm = FALSE, show.legend = NA,
                              inherit.aes = TRUE){
  if (is.character(position)) {
    if (varwidth == TRUE) position <- position_dodge2(preserve = "single")
  } else {
    if (identical(position$preserve, "total") & varwidth == TRUE) {
      warning("Can't preserve total widths when varwidth = TRUE.", call. = FALSE)
      position$preserve <- "single"
    }
  }
  layer(data = data, mapping = mapping, stat = stat,
        geom = GeomMeanDiamonds, position = position,
        show.legend = show.legend, inherit.aes = inherit.aes,
        params = list(varwidth = varwidth, na.rm = na.rm, ...))
}

stat_meanDiamonds <- function(mapping = NULL, data = NULL,
                         geom = "meanDiamonds", position = "dodge2",
                         ..., ci = 0.95,
                         na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
  layer(data = data, mapping = mapping, stat = StatMeanDiamonds,
        geom = geom, position = position, show.legend = show.legend,
        inherit.aes = inherit.aes,
        params = list(na.rm = na.rm, ci = ci, ...))
}

第 5 步。检查输出。

# basic
ggplot(iris, 
       aes(Species, Sepal.Length)) +
  geom_boxplot() +
  geom_meanDiamonds()

# with additional parameters, to see if they break anything
ggplot(iris, 
       aes(Species, Sepal.Length)) +
  geom_boxplot(width = 0.8) +
  geom_meanDiamonds(aes(fill = Species),
                    color = "red", alpha = 0.5, size = 1, 
                    ci = 0.99, width = 0.3)

【讨论】:

  • 太棒了!我一直在网上搜索这个情节。我不敢相信它不包含在 Python Seaborn 库中。我会尝试用 Python 重现这个情节,祝我好运!
猜你喜欢
  • 1970-01-01
  • 2020-04-21
  • 2021-04-12
  • 2021-11-18
  • 2011-05-03
  • 1970-01-01
  • 2011-09-14
  • 1970-01-01
相关资源
最近更新 更多