带有“lm”的线性模型：如何得到预测值之和的预测方差
我将具有多个预测变量的线性模型的预测值相加，如下例所示，并希望计算此总和的组合方差，标准误差和可能的置信区间。
lm.tree <- lm(Volume ~ poly(Girth,2), data = trees)
假设我有一组Girths：
newdat <- list(Girth = c(10,12,14,16)
我想要预测总Volume：
pr <- predict(lm.tree, newdat, se.fit = TRUE)
total <- sum(pr$fit)
# [1] 111.512
如何获取total的差异？
类似的问题是here (for GAMs)，但我不确定如何继续vcov(lm.trees)。我很感激该方法的参考。
1 个答案:
答案 0 :(得分：5)
您需要获得完整的方差 - 协方差矩阵，然后对其所有元素求和。以下是小证明：
这里的证据是使用另一个定理，您可以从Covariance-wikipedia找到：
具体来说，我们采用的线性变换是所有1的列矩阵。生成的二次形式计算为as following，所有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的工作原理，请参阅How does predict.lm() compute confidence interval and prediction interval?。以下小函数lm_predict模仿它的作用，除了
- 它不构建置信区间或预测区间（但是Q＆amp; 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
备注
此答案已得到改进，可为Linear regression with `lm()`: prediction interval for aggregated predicted values提供易于使用的功能。
升级（适用于大数据）
太好了！非常感谢！有一件事我忘了提到：在我的实际应用中，我需要总结约300,000个预测，这将产生一个大约为700GB大小的完全方差 - 协方差矩阵。你有没有想过是否有一种计算上更有效的方法来直接得到方差 - 协方差矩阵之和？
感谢Linear regression with `lm()`: prediction interval for aggregated predicted values的OP对此非常有用的评论。是的，这是可能的，而且（显着）计算上更便宜。目前，lm_predict形成了方差 - 协方差：
agg_pred将预测方差（用于构建CI）计算为二次形式：w'(B'B)w，并将预测方差（用于构建PI）计算为另一种二次形式w'(B'B + D)w，其中{{} 1}}是残差方差的对角矩阵。显然，如果我们融合这两个函数，我们有一个更好的计算策略：
避免了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)
}
是的，答案是对的！
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？