如何使用 R 中的多重插补数据执行自举以估计和推断分位数回归？

Question

我正在尝试手动合并来自使用mice在 R 中的多重插补数据上运行的分位数回归模型的结果。 我使用引导程序来获得 model 术语的 95% CI 和 P 值，其中 model 参数及其标准误差是在采样一定数量的行后获得的，该行数等于我的数据集中唯一的参与者数量. 对于m个估算数据集的每一个，该过程重复 500 次。 然后，作为最后一步，我根据 Rubin 的规则 (1987)（参见例如https://bookdown.org/mwheymans/bookmi/rubins-rules . html ）。 为了加快速度，我使用foreach将分析拆分到多个处理器内核上，并for循环遍历m个插补数据集。

但是，合并结果的部分似乎存在缺陷。 当我查看汇总结果时，我观察到 P 值与 95% CI 不一致（例如，当 0 包含在 95% CI 中时，P < 0.05）。

为了说明这个问题，我使用这些公开可用的数据制作了一个可重复的示例： https://archive.ics.uci.edu/ml/machine-learning-databases/00519/heart_failure_clinical_records_dataset.csv

因为这个数据集中没有缺失数据，所以我自己介绍一下，对数据进行插补（ m = 10个插补数据集，20次迭代）。 我使用set.seed来实现可重复性。

请注意，在此示例中，我使用lm而不是quantreg::rq 。

# load data
projdir <- "my_directory"
d <- read.csv(file = file.path(projdir, 'heart_failure_clinical_records_dataset.csv'))

#### introduce missing values
set.seed(1)

# age
age_miss_tag <- rbinom(nrow(d), 1, 0.3)
d$age[age_miss_tag == 1] <- NA # MCAR
# serum creatinine
creat_miss_tag <- rbinom(nrow(d), 1, 0.3)
d$serum_creatinine[creat_miss_tag == 1 & d$anaemia == 0] <- NA # MAR
# CK
CK_miss_tag <- rbinom(nrow(d), 1, 0.3)
d$creatinine_phosphokinase[CK_miss_tag & d$platelets > median(d$platelets)] <- NA # MAR
# platelets
platelets_miss_tag <- rbinom(nrow(d), 1, 0.3)
d$platelets[platelets_miss_tag == 1] <- NA # MCAR

library(mice); library(mitml); library(miceadds); library(splines); library(foreach); library(doParallel)

# impute data
imp <- mice(d, maxit = 20, m = 10, seed = 2)

# log creatinine
implong <- complete(imp, 'long', include = FALSE)
implong$log_creat <- log(implong$serum_creatinine)
imp <- miceadds::datlist2mids(split(implong, implong$.imp))

# compute values for Boundary.knots
temp <- complete(imp, 'long', include = FALSE)
B_knots <- rowMeans(sapply(split(temp, temp$.imp), function(x) {
  quantile(x$age, c(0.1, 0.9))
}))

# Convert mids object into a datlist
longlist <- miceadds::mids2datlist(imp)

# fit model based on origial data and use the terms in the below foreach loop
# in order to fix the position of the inner knots
fit_orig <- lm(log_creat ~ 
                 
                 # Main effects
                 ns(age, df = 2, B = c(B_knots[1], B_knots[2])) * sex,
               
               data = longlist[[1]])

为了进一步加快速度，我在这里使用 OLS 而不是分位数回归并并行化该过程。

# make cluster used in foreach
cores_2_use <- detectCores() - 1
cl <- makeCluster(cores_2_use)
clusterSetRNGStream(cl, iseed = 9956)
registerDoParallel(cl)

# No. of bootstrap samples to be taken
n_iter <- 500

boot.1 <- c()
for(k in seq_along(longlist)){
  boot.1[[k]] <- foreach(i = seq_len(n_iter),
                         .combine = rbind,
                         .packages = c('mice', 'mitml', 'splines')) %dopar% {
                           
                           # store data from which rows can be samples
                           longlist0 <- longlist[[k]]
                           
                           # set seed for reproducibility
                           set.seed(i)
                           
                           # sample rows
                           boot_dat <- longlist0[sample(1:nrow(longlist0), replace = TRUE), ]
                           
                           # linear regression model based on sampled rows
                           fit1 <- lm(terms(fit_orig), data = boot_dat)
                           
                           # save coefficients
                           fit1$coef
                           
                         }
}
stopCluster(cl)

作为最后一步，我根据 Rubin 的规则汇总结果。

n_cols <- dim(boot.1[[1]])[2]
list <- c()
for(i in seq_len(n_cols)) {
  
  # extract coefficients
  parameter <- lapply(boot.1, function(x){
    x[,i]
  })
  
  m <- length(parameter)
  for(k in seq_len(m)) {
    names(parameter[[k]]) <- NULL
  }
  
  Q <- sapply(parameter, mean)
  U <- sapply(parameter, var) # (standard error of estimate)^2
  
  #### Pooling
  # Pooled univariate estimate
  qbar <- mean(Q)
  
  # Mean of the variances (i.e. the pooled within-imputation variance)
  ubar <- mean(U)
  
  # Between-imputation variance
  btw_var <- var(Q)
  
  # Total variance of the pooled estimated
  tot_var <- ubar + btw_var + (btw_var / m)
  
  # Relative increase in variance due to non-response
  r_var <- (btw_var + (btw_var / m)) / ubar
  
  # Fraction of missing information
  lambda <- (btw_var + (btw_var / m)) / tot_var
  
  # degrees of freedom for the t-distribution according to Rubin (1987)
  df_old <- (m - 1) / lambda^2
  
  # sample size in the imputed data sets
  n_sample <- nrow(longlist[[1]])
  
  # observed degrees of freedom
  df_observed <- (((n_sample - n_cols) + 1) / ((n_sample - n_cols) + 3)) *
    (n_sample - n_cols) * (1 - lambda)
  
  # adjusted degrees of freedom according to Barnard & Rubin (1999)
  df_adjusted <- (df_old * df_observed) / (df_old + df_observed)
  
  # 95% confidence interval of qbar
  lwr <- qbar - qt(0.975, df_adjusted) * sqrt(tot_var)
  upr <- qbar + qt(0.975, df_adjusted) * sqrt(tot_var)
  
  # F statistic
  q <- ((0 - qbar)^2 / tot_var)^2
  
  # Significance level associated with the null value Q[0]
  p_value <- pf(q, df1 = 1, df2 = df_adjusted, lower.tail = FALSE)
  
  list[[i]] <- cbind(qbar, lwr, upr, p_value)
  
}
names(list) <- colnames(boot.1[[1]])
list

显然，下图的P值不符合95% CI（因为0包含在CI中，所以P值应该≥0.05）。

> list
$`(Intercept)`
           qbar         lwr       upr     p_value
[1,] 0.06984595 -0.02210231 0.1617942 0.008828337

---

编辑（2021 年 12 月 29 日）

正如@Gerko Vink 在他的回答中指出的那样，多重插补和引导都会导致方差。 插补引起的方差由鲁宾规则处理，引导方差不是。 不幸的是， mice::pool不能与quantreg::rq返回的 output 一起使用。

我知道基于本文所示的基于百分位的简单方法构建引导 CI，但我倾向于认为这不是正确的方法。

有谁知道在使用rq时如何适当地处理由引导引起的额外方差？

---

编辑（2021 年 12 月 30 日）

受最近这篇文章的启发，我决定不再走自举的道路，而是从每个估算的数据集中手动提取点估计和方差，并使用鲁宾规则手动合并它们。 我已将这种方法发布为下面的答案。

Answer 1

自举和多重插补都会引起方差。 插补方差由具有正态采样分布的参数的鲁宾规则处理。 引导方差不是。

两个备注：

首先，您的代码中有一个小错误。 您正在计算U <- sapply(parameter, var)中关于Q的引导方差。 不需要U <- U/n_iter 。 U已经是方差并且sapply(parameter, sd)将产生自举标准误差。

其次，您使用引导参数来计算参数区间和 p 值。 这似乎不必要地复杂，并且如您所见，可能存在问题。 为什么不计算引导 CI？

另请参阅 此链接以获取有关计算 CI 的不同方法及其各自有效性的一些灵感。

一个小型模拟程序，它表明对于有限的引导复制集，您不能期望两者是相同的。

library(purrr)
library(magrittr)
#> 
#> Attaching package: 'magrittr'
#> The following object is masked from 'package:purrr':
#> 
#>     set_names

#fix seed
set.seed(123)

#some data
n = 1000
d <- rnorm(n, 0, 1)

# ci function
fun <- function(x){
  se <- var(x)/length(x)
  lwr <- mean(x) - 1.96 * se
  upr <- mean(x) + 1.96 * se
  ci <- c(lwr, upr)
  return(ci)
}

# bootstrap
boot <- replicate(500, 
                  d[sample(1:1000, 1000, replace = TRUE)], 
                  simplify = FALSE)

# bootstrapped ci's based on parameters
boot.param.ci <- boot %>% 
  map(~.x %>% fun) %>% 
  do.call("rbind", args = .)

# bootstrap CI
boot.ci <- boot %>% 
  map(~.x %>% mean) %>% 
  unlist %>% 
  quantile(c(.025, .975))

# Overview
data.frame(param = fun(d), 
           boot.param = boot.param.ci %>% colMeans,
           boot.ci = boot.ci)
#>            param boot.param     boot.ci
#> 2.5%  0.01420029 0.01517527 -0.05035913
#> 97.5% 0.01805545 0.01904181  0.07245449

^{由代表 package (v2.0.1) 于 2021 年 12 月 22 日创建}

Answer 2

对于分位数回归， mice::pool不能与quantreg::rq返回的 output 一起使用，因为（根据这篇文章）没有商定的计算标准误差的方法，这是在多重插补下合并结果所必需的。

一个特别的解决方案是从每个估算的数据集中手动提取点估计和方差，并使用鲁宾规则将它们汇集起来。

首先，使用lm来验证手动方法和mice::pool的结果是否相同的reprex 。

library(mice); library(quantreg)

imp <- mice(nhanes, print = FALSE, seed = 123)

# fit linear model
fit <- with(imp, lm(bmi ~ chl + hyp))

# manually pool univariate estimates using Rubin's rules
pool_manual <- \(model_object) {
  m <- length(model_object$analyses)
  Q <- sapply(model_object$analyses, \(x) summary(x)$coefficients[, 'Estimate'])
  U <- sapply(model_object$analyses, \(x) (summary(x)$coefficients[, 'Std. Error'])^2)
  qbar <- rowMeans(Q)
  ubar <- rowMeans(U)
  btw_var <- apply(Q, 1, var)
  tot_var <- ubar + btw_var + (btw_var / m)
  lambda <- (btw_var + (btw_var / m)) / tot_var
  df_old <- (m - 1) / lambda^2
  n_sample <- length(residuals(model_object$analyses[[1]]))
  n_cols <- dim(Q)[1]
  df_com <- n_sample - n_cols
  df_observed <- ((df_com + 1) / (df_com + 3)) * df_com * (1 - lambda)
  df_adjusted <- (df_old * df_observed) / (df_old + df_observed)
  lwr <- qbar - qt(0.975, df_adjusted) * sqrt(tot_var)
  upr <- qbar + qt(0.975, df_adjusted) * sqrt(tot_var)
  q <- (0 - qbar)^2 / tot_var
  p_value <- pf(q, df1 = 1, df2 = df_adjusted, lower.tail = FALSE)
  df <- data.frame(noquote(rownames(Q)), qbar, lwr, upr, p_value)
  rownames(df) <- NULL
  names(df) <- c('term', 'estimate', '2.5 %', '97.5 %', 'p.value')
  return(df)
}

核实。

> pool_manual(fit)
         term    estimate       2.5 %      97.5 %     p.value
1 (Intercept) 21.78583831  8.99373786 34.57793875 0.004228746
2         chl  0.03303449 -0.02812005  0.09418903 0.254696358
3         hyp -1.07291395 -5.57406829  3.42824039 0.624035769

> extract <- c('term', 'estimate', '2.5 %', '97.5 %', 'p.value')
> summary(pool(fit), conf.int = TRUE)[, extract]
         term    estimate       2.5 %      97.5 %     p.value
1 (Intercept) 21.78583831  8.99373786 34.57793875 0.004228746
2         chl  0.03303449 -0.02812005  0.09418903 0.254696358
3         hyp -1.07291395 -5.57406829  3.42824039 0.624035769

分位数回归

现在，让我们将rq的结果汇总为结果的预期中位数。

library(quantreg)

# fit quantile regression model
fit <- with(imp, rq(bmi ~ chl + hyp, tau = 0.5))

为了能够从rq汇集结果，只有用于从每个估算数据集中提取点估计和方差的汇总方法需要在pool_manual中进行调整。

Q <- sapply(model_object$analyses, \(x) summary.rq(x, covariance = TRUE)$coefficients[, 'Value'])
U <- sapply(model_object$analyses, \(x) (summary.rq(x, covariance = TRUE)$coefficients[, 'Std. Error'])^2)

结果

> pool_manual(fit)
         term    estimate      2.5 %     97.5 %    p.value
1 (Intercept) 22.23452856  0.8551626 43.6138945 0.04461337
2         chl  0.03487894 -0.0857199  0.1554778 0.47022312
3         hyp -1.43636147 -6.0666990  3.1939761 0.52455041

> summary(pool(fit), conf.int = TRUE)[, extract]
Error in rq.fit.br(x, y, tau = tau, ci = TRUE, ...) : 
  unused arguments (effects = "fixed", parametric = TRUE, exponentiate = FALSE)