使用`lm`的线性模型：如何获取预测值之和的预测方差

Question

我正在对多个预测变量的线性模型进行预测值求和，就像下面的例子一样，并希望计算这个总和的组合方差、标准误差和可能的置信区间。

lm.tree <- lm(Volume ~ poly(Girth,2), data = trees)

假设我有一组名为Girths的集合：

newdat <- list(Girth = c(10,12,14,16)

我希望能够预测总销售量:

pr <- predict(lm.tree, newdat, se.fit = TRUE)
total <- sum(pr$fit)
# [1] 111.512

我如何获得total的方差？

类似的问题可以在这里 （对于 GAMs）找到答案，但我不确定如何使用vcov(lm.trees)。如果有方法的参考资料，我会非常感激。

- CCID

Answer 1

您需要获取完整的方差-协方差矩阵，然后将其所有元素相加。 这是一个小证明：

这里的证明使用了另一个定理，你可以在Covariance-wikipedia中找到它：

具体来说，我们采用的线性变换是一个全为1的列矩阵。得到的二次型 计算方法如下，其中所有的x_i和x_j都是1。

---

设置

## your model
lm.tree <- lm(Volume ~ poly(Girth, 2), data = trees)

## newdata (a data frame)
newdat <- data.frame(Girth = c(10, 12, 14, 16))

重新实现predict.lm以计算方差协方差矩阵

请参见如何使用predict.lm（）计算置信区间和预测区间？了解predict.lm的工作原理。以下小函数lm_predict模仿它的工作方式，除了：

• 它不构建置信区间或预测区间（但是根据该Q&A中所述非常简单）；
• 如果diag = FALSE，它可以计算预测值的完整方差协方差矩阵；
• 它返回方差（对于预测值和残差），而不是标准误差；
• 它无法执行type =“terms”； 它只能预测响应变量。

lm_predict <- function (lmObject, newdata, diag = TRUE) {
  ## input checking
  if (!inherits(lmObject, "lm")) stop("'lmObject' is not a valid 'lm' object!")
  ## extract "terms" object from the fitted model, but delete response variable
  tm <- delete.response(terms(lmObject))      
  ## linear predictor matrix
  Xp <- model.matrix(tm, newdata)
  ## predicted values by direct matrix-vector multiplication
  pred <- c(Xp %*% coef(lmObject))
  ## efficiently form the complete variance-covariance matrix
  QR <- lmObject$qr   ## qr object of fitted model
  piv <- QR$pivot     ## pivoting index
  r <- QR$rank        ## model rank / numeric rank
  if (is.unsorted(piv)) {
    ## pivoting has been done
    B <- forwardsolve(t(QR$qr), t(Xp[, piv]), r)
    } else {
    ## no pivoting is done
    B <- forwardsolve(t(QR$qr), t(Xp), r)
    }
  ## residual variance
  sig2 <- c(crossprod(residuals(lmObject))) / df.residual(lmObject)
  if (diag) {
    ## return point-wise prediction variance
    VCOV <- colSums(B ^ 2) * sig2
    } else {
    ## return full variance-covariance matrix of predicted values
    VCOV <- crossprod(B) * sig2
    }
  list(fit = pred, var.fit = VCOV, df = lmObject$df.residual, residual.var = sig2)
  }

我们可以将其输出与 predict.lm 进行比较：

predict.lm(lm.tree, newdat, se.fit = TRUE)
#$fit
#       1        2        3        4 
#15.31863 22.33400 31.38568 42.47365 
#
#$se.fit
#        1         2         3         4 
#0.9435197 0.7327569 0.8550646 0.8852284 
#
#$df
#[1] 28
#
#$residual.scale
#[1] 3.334785

lm_predict(lm.tree, newdat)
#$fit
#[1] 15.31863 22.33400 31.38568 42.47365
#
#$var.fit    ## the square of `se.fit`
#[1] 0.8902294 0.5369327 0.7311355 0.7836294
#
#$df
#[1] 28
#
#$residual.var   ## the square of `residual.scale`
#[1] 11.12079

特别是：

oo <- lm_predict(lm.tree, newdat, FALSE)
oo
#$fit
#[1] 15.31863 22.33400 31.38568 42.47365
#
#$var.fit
#            [,1]      [,2]       [,3]       [,4]
#[1,]  0.89022938 0.3846809 0.04967582 -0.1147858
#[2,]  0.38468089 0.5369327 0.52828797  0.3587467
#[3,]  0.04967582 0.5282880 0.73113553  0.6582185
#[4,] -0.11478583 0.3587467 0.65821848  0.7836294
#
#$df
#[1] 28
#
#$residual.var
#[1] 11.12079

请注意，方差-协方差矩阵并不是以天真的方式计算的：Xp %*% vcov(lmObject) % t(Xp)，这种方法很慢。

聚合（求和）

在您的情况下，聚合操作是oo$fit中所有值的总和。此聚合的均值和方差为：

sum_mean <- sum(oo$fit)  ## mean of the sum
# 111.512

sum_variance <- sum(oo$var.fit)  ## variance of the sum
# 6.671575

你可以使用t分布和模型中的剩余自由度，对这个汇总值进一步构建置信区间（CI）。

alpha <- 0.95
Qt <- c(-1, 1) * qt((1 - alpha) / 2, lm.tree$df.residual, lower.tail = FALSE)
#[1] -2.048407  2.048407

## %95 CI
sum_mean + Qt * sqrt(sum_variance)
#[1] 106.2210 116.8029

构建预测区间(PI)需要进一步考虑残差方差。

## adjusted variance-covariance matrix
VCOV_adj <- with(oo, var.fit + diag(residual.var, nrow(var.fit)))

## adjusted variance for the aggregation
sum_variance_adj <- sum(VCOV_adj)  ## adjusted variance of the sum

## 95% PI
sum_mean + Qt * sqrt(sum_variance_adj)
#[1]  96.86122 126.16268

聚合（一般情况下）

一般的聚合操作可以是 oo$fit 的线性组合：

w[1] * fit[1] + w[2] * fit[2] + w[3] * fit[3] + ...

例如，求和操作的所有权重都为1；平均操作的所有权重都为0.25（在4个数据的情况下）。这是一个函数，它接受一个权重向量、一个显著性水平和由 lm_predict 返回的内容，以生成聚合统计信息。

agg_pred <- function (w, predObject, alpha = 0.95) {
  ## input checing
  if (length(w) != length(predObject$fit)) stop("'w' has wrong length!")
  if (!is.matrix(predObject$var.fit)) stop("'predObject' has no variance-covariance matrix!")
  ## mean of the aggregation
  agg_mean <- c(crossprod(predObject$fit, w))
  ## variance of the aggregation
  agg_variance <- c(crossprod(w, predObject$var.fit %*% w))
  ## adjusted variance-covariance matrix
  VCOV_adj <- with(predObject, var.fit + diag(residual.var, nrow(var.fit)))
  ## adjusted variance of the aggregation
  agg_variance_adj <- c(crossprod(w, VCOV_adj %*% w))
  ## t-distribution quantiles
  Qt <- c(-1, 1) * qt((1 - alpha) / 2, predObject$df, lower.tail = FALSE)
  ## names of CI and PI
  NAME <- c("lower", "upper")
  ## CI
  CI <- setNames(agg_mean + Qt * sqrt(agg_variance), NAME)
  ## PI
  PI <- setNames(agg_mean + Qt * sqrt(agg_variance_adj), NAME)
  ## return
  list(mean = agg_mean, var = agg_variance, CI = CI, PI = PI)
  }

之前的求和操作进行了快速测试：

agg_pred(rep(1, length(oo$fit)), oo)
#$mean
#[1] 111.512
#
#$var
#[1] 6.671575
#
#$CI
#   lower    upper 
#106.2210 116.8029 
#
#$PI
#    lower     upper 
# 96.86122 126.16268 

并进行平均操作的快速测试：

agg_pred(rep(1, length(oo$fit)) / length(oo$fit), oo)
#$mean
#[1] 27.87799
#
#$var
#[1] 0.4169734
#
#$CI
#   lower    upper 
#26.55526 29.20072 
#
#$PI
#   lower    upper 
#24.21531 31.54067 

---

备注

本答案已经改进，提供易于使用的功能，用于使用`lm()`进行线性回归：预测聚合预测值的预测区间。

---

升级（针对大数据）

太好了！非常感谢！有一件事我忘了提：在我的实际应用中，我需要对约300,000个预测值求和，这将创建一个大小约为700GB的完整方差-协方差矩阵。您是否知道是否有更加计算高效的方法直接得到方差-协方差矩阵的总和？

感谢使用`lm()`进行线性回归：聚合预测值的预测区间的原始帖子作者提供此非常有用的评论。是的，这是可能的，而且也（显著地）计算成本更低。目前，lm_predict形成方差-协方差矩阵如下：

agg_pred 函数计算预测方差（用于构建置信区间）为二次型： w'(B'B)w，并且计算预测方差（用于构建预测区间）为另一个二次型 w'(B'B + D)w，其中 D 是残差方差的对角矩阵。显然，如果我们合并这两个函数，就可以得到更好的计算策略：

避免了对B和B'B的计算；我们将所有矩阵-矩阵乘法替换为矩阵-向量乘法。没有B和B'B的内存存储；只有u，它只是一个向量。这是融合实现。

## this function requires neither `lm_predict` nor `agg_pred`
fast_agg_pred <- function (w, lmObject, newdata, alpha = 0.95) {
  ## input checking
  if (!inherits(lmObject, "lm")) stop("'lmObject' is not a valid 'lm' object!")
  if (!is.data.frame(newdata)) newdata <- as.data.frame(newdata)
  if (length(w) != nrow(newdata)) stop("length(w) does not match nrow(newdata)")
  ## extract "terms" object from the fitted model, but delete response variable
  tm <- delete.response(terms(lmObject))      
  ## linear predictor matrix
  Xp <- model.matrix(tm, newdata)
  ## predicted values by direct matrix-vector multiplication
  pred <- c(Xp %*% coef(lmObject))
  ## mean of the aggregation
  agg_mean <- c(crossprod(pred, w))
  ## residual variance
  sig2 <- c(crossprod(residuals(lmObject))) / df.residual(lmObject)
  ## efficiently compute variance of the aggregation without matrix-matrix computations
  QR <- lmObject$qr   ## qr object of fitted model
  piv <- QR$pivot     ## pivoting index
  r <- QR$rank        ## model rank / numeric rank
  u <- forwardsolve(t(QR$qr), c(crossprod(Xp, w))[piv], r)
  agg_variance <- c(crossprod(u)) * sig2
  ## adjusted variance of the aggregation
  agg_variance_adj <- agg_variance + c(crossprod(w)) * sig2
  ## t-distribution quantiles
  Qt <- c(-1, 1) * qt((1 - alpha) / 2, lmObject$df.residual, lower.tail = FALSE)
  ## names of CI and PI
  NAME <- c("lower", "upper")
  ## CI
  CI <- setNames(agg_mean + Qt * sqrt(agg_variance), NAME)
  ## PI
  PI <- setNames(agg_mean + Qt * sqrt(agg_variance_adj), NAME)
  ## return
  list(mean = agg_mean, var = agg_variance, CI = CI, PI = PI)
  }

让我们进行快速测试。

## sum opeartion
fast_agg_pred(rep(1, nrow(newdat)), lm.tree, newdat)
#$mean
#[1] 111.512
#
#$var
#[1] 6.671575
#
#$CI
#   lower    upper 
#106.2210 116.8029 
#
#$PI
#    lower     upper 
# 96.86122 126.16268 

## average operation
fast_agg_pred(rep(1, nrow(newdat)) / nrow(newdat), lm.tree, newdat)
#$mean
#[1] 27.87799
#
#$var
#[1] 0.4169734
#
#$CI
#   lower    upper 
#26.55526 29.20072 
#
#$PI
#   lower    upper 
#24.21531 31.54067 

是的，答案正确！

- Zheyuan Li