R LM的覆盖概率计算

我试图计算我在回归截距和斜率上生成的一组剩余引导复制的覆盖概率。有人能告诉我如何计算置信区间的覆盖概率吗？非常感谢

请注意，我使用Qr分解手动运行回归，但如果更简单的话，可以使用

lm（）

。我只是觉得手动操作会更快

set.seed(42)  ## for sake of reproducibility
n <- 100
x <- rnorm(n)
e <- rnorm(n)
y <- as.numeric(50 + 25*x + e)
dd <- data.frame(id=1:n, x=x, y=y)

mo <- lm(y ~ x, data=dd)

# Manual Residual Bootstrap
resi <- residuals(mo)
fit <- fitted(mo)
ressampy <- function() fit + sample(resi, length(resi), replace=TRUE)
# Sample y values:
head(ressampy())
# Qr decomposition of X values
qrX <- qr(cbind(Intercept=1, dd[, "x", drop=FALSE]), LAPACK=TRUE)
# faster than LM
qr.coef(qrX, dd[, "y"])
# One Bootstrap replication
boot1 <- qr.coef(qrX, ressampy())
# 1000 bootstrap replications
boot <- t(replicate(1000, qr.coef(qrX, ressampy())))

根据，覆盖概率定义为实际θ在自举置信区间（CI）内的频率概率（即，基于实际数据或换句话说，新实验应用于多个样本的模型的概率）：

因此，我们希望根据OP提出的i.i.d.引导

R

时间计算CI，并计算θ在这些CI中的频率比率

首先，我们使用实际数据估计我们的模型

mo

mo <- lm(y ~ x)

在bootstrap函数

FUN

中，我们将要执行的所有步骤封装在一个复制中。为了应用非常快速的

.lm.fit

，我们必须手动计算白色标准误差（与

lmtest:：coeftest（fit，vcov.=sandwich:：vcovHC（fit，type=“HC1”））

）

同时跨行或分别在每列中的

TRUE

s的

mean

给出了我们正在寻找的覆盖概率

(cp.t <- mean(apply(v <- res, 1, all)))  ## coverage probability total  
(cp.i <- colMeans(res))  ## coverage probability individual coefs
(cp <- c(total=cp.t, cp.i))
#  total intercept         x
# 0.8954    0.9478    0.9444

## values with other R:
#   total intercept         x
# 0.90700   0.95200   0.95200  ## R ==   1k
# 0.89950   0.95000   0.94700  ## R ==   2k
# 0.89540   0.94780   0.94440  ## R ==   5k
# 0.89530   0.94570   0.94680  ## R ==  10k
# 0.89722   0.94694   0.94777  ## R == 100k

---

（cp.t太棒了！谢谢！它有各种名称（例如，iid引导、fixed-x重采样），这可能就是它引起一些混乱的原因。有关该方法的介绍，请参阅。酷！最初我遇到了困难，因为我无法提取CI，而只能从基于QR分解的复制数据中提取系数（出于这个原因，我认为这是一条死胡同），尽管后来我通过使用
lm（）通过附加一些白色标准错误来查找CI。但有一点很清楚，所有结果都有助于澄清覆盖概率的定义，即捕获真实系数的CI的比率。@cliu太好了，我们有了它！我还为游戏添加了一些颜色和情节。请参阅更新。@cliu请注意我对
乐趣的编辑根据排序列表（fit$pivot）
对系数进行排序。
yhat <- mo$fitted.values
u <- as.matrix(mo$residuals)
X <- model.matrix(mo)
theta <- c(50, 25)  ## known from data generating process of simulation

FUN <- function() {
  ## resampling residuals
  y.star <- yhat + sample(u, length(u), replace=TRUE)
  ## refit model
  fit <- .lm.fit(X, y.star)
  coef <- fit$coefficients[sort.list(fit$pivot)]
  ## alternatively using QR, but `.lm.fit` is slightly faster
  # qrX <- qr(X, LAPACK=TRUE)
  # coef <- qr.coef(qrX, y.star)
  ## white standard errors
  v.cov <- chol2inv(chol(t(X) %*% X))
  meat <- t(X) %*% diag(diag(u %*% t(u))) %*% X
  ## degrees of freedom adjust (HC1)
  d <- dim(X)
  dfa <- d[1] / (d[1] - d[2])
  white.se <- sqrt(diag(v.cov %*% meat %*% v.cov)*dfa)
  ## 95% CIs
  ci <- coef + qt(1 - .025, d[1] - d[2])*white.se %*% t(c(-1, 1))
  ## coverage
  c(intercept=theta[1] >= ci[1, 1] & theta[1] <= ci[1, 2],
    x=theta[2] >= ci[2, 1] & theta[2] <= ci[2, 2])
}

R <- 5e3
set.seed(42)
system.time(res <- t(replicate(R, FUN())))
#   user  system elapsed
#  71.19   28.25  100.28 

head(res, 3)
#      intercept    x
# [1,]      TRUE TRUE
# [2,]     FALSE TRUE
# [3,]      TRUE TRUE

(cp.t <- mean(apply(v <- res, 1, all)))  ## coverage probability total  
(cp.i <- colMeans(res))  ## coverage probability individual coefs
(cp <- c(total=cp.t, cp.i))
#  total intercept         x
# 0.8954    0.9478    0.9444

## values with other R:
#   total intercept         x
# 0.90700   0.95200   0.95200  ## R ==   1k
# 0.89950   0.95000   0.94700  ## R ==   2k
# 0.89540   0.94780   0.94440  ## R ==   5k
# 0.89530   0.94570   0.94680  ## R ==  10k
# 0.89722   0.94694   0.94777  ## R == 100k

set.seed(42)
n <- 1e3
x <- rnorm(n)
y <- 50 + 25*x + rnorm(n)