具有lm（）的线性回归：汇总预测值的预测间隔

Question

我正在使用predict.lm(fit, newdata=newdata, interval="prediction")来获取预测及其对新观测值的预测间隔（PI）。现在，我想基于一个附加变量（即，单个家庭的预测的邮政编码级别上的空间聚合）汇总（求和均值）这些预测及其PI。

我了解到from StackExchange，您不能仅通过汇总预测间隔的限制来汇总单个预测的预测间隔。这篇文章对理解为什么不能做到这一点非常有帮助，但是我很难把这一点翻译成实际的代码。答案是：

这是一个可重复的示例：

library(dplyr)
set.seed(123)

data(iris)

#Split dataset in training and prediction set
smp_size <- floor(0.75 * nrow(iris))
train_ind <- sample(seq_len(nrow(iris)), size = smp_size)
train <- iris[train_ind, ]
pred <- iris[-train_ind, ]

#Fit regression model
fit1 <- lm(Petal.Width ~ Petal.Length, data=train)

#Fit multiple linear regression model
fit2 <- lm(Petal.Width ~ Petal.Length + Sepal.Width + Sepal.Length, data=train)

#Predict Pedal.Width for new data incl prediction intervals for each prediction
predictions1<-predict(fit1, newdata=pred, interval="prediction")
predictions2<-predict(fit2, newdata=pred, interval="prediction")

# Aggregate data by summing predictions for species
#NOT correct for prediction intervals
predictions_agg1<-data.frame(predictions1,Species=pred$Species) %>%
  group_by(Species) %>%
  summarise_all(funs(sum,mean))

predictions_agg2<-data.frame(predictions2,Species=pred$Species) %>%
  group_by(Species) %>%
  summarise_all(funs(sum,mean))

我找不到一个好的教程或软件包来描述如何在使用predict.lm()的情况下正确地汇总预测及其在R中的PI。那里有东西吗？如果您能为我指出如何在R中执行此操作的正确方向，将不胜感激。

Answer 1

您的问题与我2年前回答的主题密切相关：linear model with `lm`: how to get prediction variance of sum of predicted values。它提供Glen_b's answer on Cross Validated的R实现。感谢您引用交叉验证线程；我不知道也许我可以在此处留下链接堆栈溢出线程的注释。

我已经完善了最初的答案，将逐行代码干净地包装到易于使用的功能lm_predict和agg_pred中。然后，将解决问题的过程简化为按组应用这些功能。

考虑问题中的iris示例和第二个模型fit2进行演示。

set.seed(123)
data(iris)

#Split dataset in training and prediction set
smp_size <- floor(0.75 * nrow(iris))
train_ind <- sample(seq_len(nrow(iris)), size = smp_size)
train <- iris[train_ind, ]
pred <- iris[-train_ind, ]

#Fit multiple linear regression model
fit2 <- lm(Petal.Width ~ Petal.Length + Sepal.Width + Sepal.Length, data=train)

我们将pred按组Species划分，然后将lm_predict（带有diag = FALSE）应用于所有子数据帧。

oo <- lapply(split(pred, pred$Species), lm_predict, lmObject = fit2, diag = FALSE)

要使用agg_pred，我们需要指定一个权重向量，其长度等于数据数量。我们可以通过查询每个fit中oo[[i]]的长度来确定这一点：

n <- lengths(lapply(oo, "[[", 1))
#setosa versicolor  virginica 
#    11         13         14 

如果聚合操作是总和，我们会这样做

w <- lapply(n, rep.int, x = 1)
#List of 3
# $ setosa    : num [1:11] 1 1 1 1 1 1 1 1 1 1 ...
# $ versicolor: num [1:13] 1 1 1 1 1 1 1 1 1 1 ...
# $ virginica : num [1:14] 1 1 1 1 1 1 1 1 1 1 ...

SUM <- Map(agg_pred, w, oo)
SUM[[1]]  ## result for the first group, for example
#$mean
#[1] 2.499728
#
#$var
#[1] 0.1271554
#
#$CI
#   lower    upper 
#1.792908 3.206549 
#
#$PI
#   lower    upper 
#0.999764 3.999693 

sapply(SUM, "[[", "CI")  ## some nice presentation for CI, for example
#        setosa versicolor virginica
#lower 1.792908   16.41526  26.55839
#upper 3.206549   17.63953  28.10812

如果聚合操作平均，我们将w重新缩放n并调用agg_pred。

w <- mapply("/", w, n)
#List of 3
# $ setosa    : num [1:11] 0.0909 0.0909 0.0909 0.0909 0.0909 ...
# $ versicolor: num [1:13] 0.0769 0.0769 0.0769 0.0769 0.0769 ...
# $ virginica : num [1:14] 0.0714 0.0714 0.0714 0.0714 0.0714 ...

AVE <- Map(agg_pred, w, oo)
AVE[[2]]  ## result for the second group, for example
#$mean
#[1] 1.3098
#
#$var
#[1] 0.0005643196
#
#$CI
#    lower    upper 
#1.262712 1.356887 
#
#$PI
#   lower    upper 
#1.189562 1.430037 

sapply(AVE, "[[", "PI")  ## some nice presentation for CI, for example
#          setosa versicolor virginica
#lower 0.09088764   1.189562  1.832255
#upper 0.36360845   1.430037  2.072496

---

  

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

使用原始问答版本中提供的fast_agg_pred函数。让我们从头开始。

set.seed(123)
data(iris)

#Split dataset in training and prediction set
smp_size <- floor(0.75 * nrow(iris))
train_ind <- sample(seq_len(nrow(iris)), size = smp_size)
train <- iris[train_ind, ]
pred <- iris[-train_ind, ]

#Fit multiple linear regression model
fit2 <- lm(Petal.Width ~ Petal.Length + Sepal.Width + Sepal.Length, data=train)

## list of new data
newdatlist <- split(pred, pred$Species)

n <- sapply(newdatlist, nrow)
#setosa versicolor  virginica 
#    11         13         14 

如果聚合操作是总和，我们会这样做

w <- lapply(n, rep.int, x = 1)
SUM <- mapply(fast_agg_pred, w, newdatlist,
              MoreArgs = list(lmObject = fit2, alpha = 0.95),
              SIMPLIFY = FALSE)

如果聚合操作是平均水平，我们会这样做

w <- mapply("/", w, n)
AVE <- mapply(fast_agg_pred, w, newdatlist,
              MoreArgs = list(lmObject = fit2, alpha = 0.95),
              SIMPLIFY = FALSE)

请注意，在这种情况下我们不能使用Map，因为我们需要为fast_agg_pred提供更多参数。在这种情况下，将mapply和MoreArgs与SIMPLIFY一起使用。