如何使 geom_smooth 不那么动态

Question

在 ggplot 中生成带分面的平滑图时，如果数据范围从一个面到另一个面发生变化，则平滑可能会为数据较少的面获得太多的自由度。

例如

library(dplyr)
library(ggplot2) # ggplot2_2.2.1

set.seed(1234)
expand.grid(z = -5:2, x = seq(-5,5, len = 50)) %>%
  mutate(y = dnorm(x) + 0.4*runif(n())) %>% 
  filter(z <= x) %>%
  ggplot(aes(x,y)) + 
  geom_line() +
  geom_smooth(method = 'loess', span = 0.3) +
  facet_wrap(~ z)

生成以下内容： z=-5 方面很好，但是当移动到后续方面时，平滑度似乎 'overfit'；事实上 z=-1 已经受到了影响，在最后一个方面，z=2，平滑线完美地拟合了数据。理想情况下，我想要的是不太动态的平滑，例如总是平滑大约 4 个点（或使用固定内核的内核平滑）。

following SO question 是相关的，但可能更雄心勃勃（因为它希望对 span 有更多的控制权）；这里我想要一个更简单的平滑形式。

Answer 1

我会简单地删除 span 选项（因为 0.3 看起来太细了）或使用 lm 方法进行多项式拟合。

library(dplyr)
library(ggplot2) # ggplot2_2.2.1

set.seed(1234)
expand.grid(z = -5:2, x = seq(-5,5, len = 50)) %>%
  mutate(y = dnorm(x) + 0.4*runif(n())) %>% 
  filter(z <= x) %>%
  ggplot(aes(x,y)) + 
  geom_line() +
  geom_smooth(method = 'lm', formula = y ~ poly(x, 4)) +
  #geom_smooth(method = 'loess') +
  #geom_smooth(method = 'loess', span = 0.3) +
  facet_wrap(~ z)

Answer 2

我在你的代码中移动了一些东西来让它工作。我不确定这是否是最好的方法，但这是一种简单的方法。

首先，我们按您的 z 变量分组，然后生成一个数字 span，该数字对于大量观测值较小，但对于少量观测值较大。我猜是 10/length(x)。也许有一些更统计合理的方式来看待它。或者它应该是 2/diff(range(x))。由于这是为了您自己的视觉平滑，因此您必须自己微调该参数。

  expand.grid(z = -5:2, x = seq(-5,5, len = 50)) %>%    
    filter(z <= x) %>%
    group_by(z) %>% 
    mutate(y = dnorm(x) + 0.4*runif(length(x)),
           span = 10/length(x)) %>% 
    distinct(z, span)

# A tibble: 8 x 2
# Groups:   z [8]
      z      span
  <int>     <dbl>
1    -5 0.2000000
2    -4 0.2222222
3    -3 0.2500000
4    -2 0.2857143
5    -1 0.3333333
6     0 0.4000000
7     1 0.5000000
8     2 0.6666667

更新

我这里的方法不能正常工作。执行此操作的最佳方法（通常也是最灵活的模型拟合方法）是预先计算它。

因此，我们将我们的分组数据框与计算的 span 相结合，用适当的跨度为每个组拟合黄土模型，然后使用 broom::augment 将其重新形成进入数据框。

  library(broom)

  expand.grid(z = -5:2, x = seq(-5,5, len = 50)) %>%    
    filter(z <= x) %>%
    group_by(z) %>% 
    mutate(y = dnorm(x) + 0.4*runif(length(x)),
           span = 10/length(x)) %>% 
    do(fit = list(augment(loess(y~x, data = ., span = unique(.$span)), newdata = .))) %>%
    unnest()

# A tibble: 260 x 7
       z    z1         x           y  span    .fitted    .se.fit
   <int> <int>     <dbl>       <dbl> <dbl>      <dbl>      <dbl>
 1    -5    -5 -5.000000 0.045482851   0.2 0.07700057 0.08151451
 2    -5    -5 -4.795918 0.248923802   0.2 0.18835244 0.05101045
 3    -5    -5 -4.591837 0.243720422   0.2 0.25458037 0.04571323
 4    -5    -5 -4.387755 0.249378098   0.2 0.28132026 0.04947480
 5    -5    -5 -4.183673 0.344429272   0.2 0.24619206 0.04861535
 6    -5    -5 -3.979592 0.256269425   0.2 0.19213489 0.05135924
 7    -5    -5 -3.775510 0.004118627   0.2 0.14574901 0.05135924
 8    -5    -5 -3.571429 0.093698117   0.2 0.15185599 0.04750935
 9    -5    -5 -3.367347 0.267809673   0.2 0.17593182 0.05135924
10    -5    -5 -3.163265 0.208380125   0.2 0.22919335 0.05135924
# ... with 250 more rows

这有复制分组列 z 的副作用，但它会智能地重命名它以避免名称冲突，因此我们可以忽略它。可以看到和原来的数据行数一样，原来的x,y,z也都在作为我们计算的 span。

如果你想向自己证明它确实适合每个组的跨度，你可以这样做：

  ... mutate(...) %>% 
    do(fit = (loess(y~x, data = ., span = unique(.$span)))) %>% 
    pull(fit) %>% purrr::map(summary)

这将打印出包含跨度的模型摘要。

现在只需绘制我们刚刚创建的增强数据框，然后手动重建平滑线和置信区间即可。

  ... %>%
    ggplot(aes(x,y)) + 
    geom_line() +
    geom_ribbon(aes(x, ymin = .fitted - 1.96*.se.fit, 
                    ymax = .fitted + 1.96*.se.fit), 
                alpha = 0.2) +
    geom_line(aes(x, .fitted), color = "blue", size = 1) +
    facet_wrap(~ z)

Answer 3

自从我询问如何进行内核平滑后，我想为提供一个答案。

我首先将它作为额外数据添加到数据框中并绘制它，就像接受的答案所做的那样。

首先是我将要使用的数据和包（与我的 post 中的相同）：

library(dplyr)
library(ggplot2) # ggplot2_2.2.1

set.seed(1234)
expand.grid(z = -5:2, x = seq(-5,5, len = 50)) %>%
  mutate(y = dnorm(x) + 0.4*runif(n())) %>% 
  filter(z <= x) ->
  Z

接下来是剧情：

Z %>%
  group_by(z) %>%
  do(data.frame(ksmooth(.$x, .$y, 'normal', bandwidth = 2))) %>%
  ggplot(aes(x,y)) + 
  geom_line(data = Z) +
  geom_line(color = 'blue', size = 1) +
  facet_wrap(~ z)

仅使用基础 R 中的 ksmooth。请注意，避免动态平滑非常简单（使带宽保持不变可以解决这一问题）。事实上，可以恢复动态样式平滑（即更像 geom_smooth），如下所示：

Z %>%
  group_by(z) %>%
  do(data.frame(ksmooth(.$x, .$y, 'normal', bandwidth = diff(range(.$x))/5))) %>%
  ggplot(aes(x,y)) + 
  geom_line(data = Z) +
  geom_line(color = 'blue', size = 1) +
  facet_wrap(~ z)

我也按照https://github.com/hrbrmstr/ggalt/blob/master/R/geom_xspline.r中的例子把这个想法变成了实际的stat_和geom_如下：

geom_ksmooth <- function(mapping = NULL, data = NULL, stat = "ksmooth",
                         position = "identity", na.rm = TRUE, show.legend = NA,
                         inherit.aes = TRUE,
                         bandwidth = 0.5, ...) {
  layer(
    geom = GeomKsmooth,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(bandwidth = bandwidth,
                  ...)
  )
}

GeomKsmooth <- ggproto("GeomKsmooth", GeomLine,
                       required_aes = c("x", "y"),
                       default_aes = aes(colour = "blue", size = 1, linetype = 1, alpha = NA)
)

stat_ksmooth <- function(mapping = NULL, data = NULL, geom = "line",
                         position = "identity", na.rm = TRUE, show.legend = NA, inherit.aes = TRUE,
                         bandwidth = 0.5, ...) {
  layer(
    stat = StatKsmooth,
    data = data,
    mapping = mapping,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(bandwidth = bandwidth,
                  ...
    )
  )
}

StatKsmooth <- ggproto("StatKsmooth", Stat,
                       required_aes = c("x", "y"),
                       compute_group = function(self, data, scales, params,
                                                bandwidth = 0.5) {
                         data.frame(ksmooth(data$x, data$y, kernel = 'normal', bandwidth = bandwidth))
                       }
)

（注意我对上面的代码理解很差。）但是现在我们可以这样做：

Z %>%
  ggplot(aes(x,y)) + 
  geom_line() +
  geom_ksmooth(bandwidth = 2) +
  facet_wrap(~ z)

并且平滑不是动态的，正如我最初想要的那样。

不过我想知道是否有更简单的方法。

如何使 geom_smooth 不那么动态

How to make geom_smooth less dynamic

r

ggplot2

loess

更新