Question

我为我的数据作了一个图，现在我想让geom_smooth（）估计的每个x的y的差值。有一个similiar question，不幸的是没有答案。例如，如何获取以下图的差异（以下数据）：

编辑

提出了两个建议，但我仍然不知道如何计算差异。

第一个建议是从ggplot对象访问数据。我是这样做的

pb <- ggplot_build(p)
pb[["data"]][[1]]

这种方法行之有效，但是数据没有为组使用相同的x值。例如，第一组的第一个x值为-3.21318853，而第二组的x则没有-3.21318853，因此，我无法计算两组之间-3.21318853的y差

第二个建议是查看geom_smooth（）中使用的公式。程序包描述说：“ loess（）用于少于1000个观测；否则，mgcv :: gam（）与公式= y〜s（x，bs =“ cs”）一起使用”。我的N大于60,000，因此默认情况下使用gam。我对gam不熟悉； 任何人都可以提供一个简短的答案，考虑到上述内容，如何计算两条线之间的差异？

R代码

library("ggplot2") # library ggplot
set.seed(1) # make example reproducible
n <- 5000 # set sample size
df <- data.frame(x= rnorm(n), g= factor(rep(c(0,1), n/2))) # generate data
df$y <- NA # include y in df
df$y[df$g== 0] <- df$x[df$g== 0]**2 + rnorm(sum(df$g== 0))*5 # y for group g= 0
df$y[df$g== 1] <-2 + df$x[df$g== 1]**2 + rnorm(sum(df$g== 1))*5 # y for g= 1 (with intercept 2)
ggplot(df, aes(x, y, col= g)) + geom_smooth() + geom_point(alpha= .1) # make a plot

Answer 1

您好，欢迎访问Stack Overflow，

第一个建议是好的。要使x序列匹配，您可以使用approx函数（在stats中）对这两个值进行插值。

library("ggplot2") # library ggplot
set.seed(1) # make example reproducible
n <- 5000 # set sample size
df <- data.frame(x= rnorm(n), g= factor(rep(c(0,1), n/2))) # generate data
df$y <- NA # include y in df
df$y[df$g== 0] <- df$x[df$g== 0]**2 + rnorm(sum(df$g== 0))*5 # y for group g= 0
df$y[df$g== 1] <-2 + df$x[df$g== 1]**2 + rnorm(sum(df$g== 1))*5 # y for g= 1 (with intercept 2)

p <- ggplot(df, aes(x, y, col= g)) + geom_smooth() + geom_point(alpha= .1) # make a plot
pb <- ggplot_build(p) # Get computed data

data.of.g1 <- pb[['data']][[1]][pb[['data']][[1]]$group == 1, ] # Extract info for group 1
data.of.g2 <- pb[['data']][[1]][pb[['data']][[1]]$group == 2, ] # Extract info for group 2

xlimit.inf <- max(min(data.of.g1$x), min(data.of.g2$x)) # Get the minimum X the two smoothed data have in common
xlimit.sup <- min(max(data.of.g1$x), max(data.of.g2$x)) # Get the maximum X
xseq <- seq(xlimit.inf, xlimit.sup, 0.01) # Sequence of X value (you can use bigger/smaller step size)

# Based on data from group 1 and group 2, interpolates linearly for all the values in `xseq`
y.g1 <- approx(x = data.of.g1$x, y = data.of.g1$y, xout = xseq)
y.g2 <- approx(x = data.of.g2$x, y = data.of.g2$y, xout = xseq)

difference <- data.frame(x = xseq, dy = abs(y.g1$y - y.g2$y)) # Compute the difference
ggplot(difference, aes(x = x, y = dy)) + geom_line() # Make the plot

输出：

Answer 2

正如我在上面的评论中提到的，您最好在 ggplot 之外进行此操作，而要使用两个平滑的完整模型来进行计算，从中可以计算出差异的不确定性，等

这基本上是我大约一年前写的blog post的简短版本。

OP的示例数据

set.seed(1) # make example reproducible
n <- 5000 # set sample size
df <- data.frame(x= rnorm(n), g= factor(rep(c(0,1), n/2))) # generate data
df$y <- NA # include y in df
df$y[df$g== 0] <- df$x[df$g== 0]**2 + rnorm(sum(df$g== 0))*5 # y for group g= 0
df$y[df$g== 1] <-2 + df$x[df$g== 1]**2 + rnorm(sum(df$g== 1))*5 # y for g= 1 (with intercept 2)

首先将模型拟合为示例数据：

library("mgcv")
m <- gam(y ~ g + s(x, by = g), data = df, method = "REML")

在这里，我正在为GAM进行因子平滑交互（by位），对于该模型，我们还需要将g作为参数效果包括在内，因为特定于组的平滑是两者都以0为中心，因此我们需要在模型的参数部分中加入组均值。

接下来，我们需要沿着x变量的数据网格，在该网格上，我们将估计两个估计的平滑之间的差异：

pdat <- with(df, expand.grid(x = seq(min(x), max(x), length = 200),
                            g = c(0,1)))
pdat <- transform(pdat, g = factor(g))

然后，我们使用此预测数据生成Xp矩阵，该矩阵将协变量的值映射到平滑的基本展开值；我们可以操纵这个矩阵来获得我们想要的平滑的差异：

xp <- predict(m, newdata = pdat, type = "lpmatrix")

接下来是一些代码，用于识别xp的各个级别上的g中的哪些行和列；因为模型中只有两个级别，并且只有一个平滑项，所以这是微不足道的，但是对于更复杂的模型，这是必需的，并且重要的是要使平滑grep()位正确使用平滑的组件名称。

## which cols of xp relate to splines of interest?
c1 <- grepl('g0', colnames(xp))
c2 <- grepl('g1', colnames(xp))
## which rows of xp relate to sites of interest?
r1 <- with(pdat, g == 0)
r2 <- with(pdat, g == 1)

现在我们可以针对正在比较的一对水平来区分xp的行

## difference rows of xp for data from comparison
X <- xp[r1, ] - xp[r2, ]

当我们关注差异时，我们需要将与所选平滑对无关的所有列归零，其中包括任何参数项。

## zero out cols of X related to splines for other lochs
X[, ! (c1 | c2)] <- 0
## zero out the parametric cols
X[, !grepl('^s\\(', colnames(xp))] <- 0

（在此示例中，这两行做的完全相同，但是在更复杂的示例中都需要。）

现在我们有了一个矩阵X，其中包含我们感兴趣的平滑对的两个基本展开之间的差，但要根据响应y的拟合值来获得此差我们需要将此矩阵乘以系数向量：

## difference between smooths
dif <- X %*% coef(m)

现在dif包含两个平滑之间的差异。

我们可以再次使用X和模型系数的协方差矩阵来计算该差异的标准误差，并因此对估计差异计算95％（在这种情况下）的置信区间。

## se of difference
se <- sqrt(rowSums((X %*% vcov(m)) * X))

## confidence interval on difference
crit <- qt(.975, df.residual(m))
upr <- dif + (crit * se)
lwr <- dif - (crit * se)

请注意，此处通过vcov()调用使用的是经验贝叶斯协方差矩阵，但未使用因选择平滑度参数而校正的矩阵。我不久之后展示的函数允许您通过参数unconditional = TRUE来解决这一额外的不确定性。

最后，我们收集结果并进行绘图：

res <- data.frame(x = with(df, seq(min(x), max(x), length = 200)),
                  dif = dif, upr = upr, lwr = lwr)

ggplot(res, aes(x = x, y = dif)) +
  geom_ribbon(aes(ymin = lwr, ymax = upr, x = x), alpha = 0.2) +
  geom_line()

这产生

这与一项评估相符，该评估表明，具有组级别平滑度的模型没有提供比具有不同组均值的模型更好的拟合度，而是x中只有一个常用的平滑度：

r$> m0 <- gam(y ~ g + s(x), data = df, method = "REML")

r$> AIC(m0, m)
         df      AIC
m0  9.68355 30277.93
m  14.70675 30285.02

r$> anova(m0, m, test = 'F')
Analysis of Deviance Table

Model 1: y ~ g + s(x)
Model 2: y ~ g + s(x, by = g)
  Resid. Df Resid. Dev     Df Deviance      F Pr(>F)
1    4990.1     124372                              
2    4983.9     124298 6.1762   73.591 0.4781 0.8301

总结

我提到的博客文章具有一个将上述步骤包装为简单函数smooth_diff()的功能：

smooth_diff <- function(model, newdata, f1, f2, var, alpha = 0.05,
                        unconditional = FALSE) {
    xp <- predict(model, newdata = newdata, type = 'lpmatrix')
    c1 <- grepl(f1, colnames(xp))
    c2 <- grepl(f2, colnames(xp))
    r1 <- newdata[[var]] == f1
    r2 <- newdata[[var]] == f2
    ## difference rows of xp for data from comparison
    X <- xp[r1, ] - xp[r2, ]
    ## zero out cols of X related to splines for other lochs
    X[, ! (c1 | c2)] <- 0
    ## zero out the parametric cols
    X[, !grepl('^s\\(', colnames(xp))] <- 0
    dif <- X %*% coef(model)
    se <- sqrt(rowSums((X %*% vcov(model, unconditional = unconditional)) * X))
    crit <- qt(alpha/2, df.residual(model), lower.tail = FALSE)
    upr <- dif + (crit * se)
    lwr <- dif - (crit * se)
    data.frame(pair = paste(f1, f2, sep = '-'),
               diff = dif,
               se = se,
               upper = upr,
               lower = lwr)
}

使用此功能，我们可以重复整个分析并通过以下方式绘制差异：

out <- smooth_diff(m, pdat, '0', '1', 'g')
out <- cbind(x = with(df, seq(min(x), max(x), length = 200)),
             out)

ggplot(out, aes(x = x, y = diff)) +
  geom_ribbon(aes(ymin = lower, ymax = upper, x = x), alpha = 0.2) +
  geom_line()

在这里我不会显示该图，因为它与上面的图相同，除了轴标签。

两条geom_smooth（）行之间的差异

2 个答案:

OP的示例数据

总结