一、题目

本题基于之前习题1.6产生关于 $(Y_1, Y_2, U)$ 的模拟数据：
$y_{i1}=1+z_{i1}$
$y_{i2}=5+2*z_{i1}+z_{i2}$
$u_i=a*(y_{i1}-1)+b*(y_{i2}-5)+z_{i3}$
其中 $\{(z_{i1}, z_{i2}, z_{i3}),i=1,...,100\}$ 服从相互独立的标准正态分布。这里构造缺失的方式主要是通过 $u_i$ 来进行构造：对某一个样本而言，若 $u_i<0$ ，则 $y_{i2}$ 缺失。

我们将分别考虑三种情况：(1) $a=0,b=0$ ；(2) $a=2,b=0$ ；(3) $a=0,b=2$ 。

在按照上述方法生成模拟数据后，我们将通过下述不同方法，计算与比较 $Y_2$ 均值与方差的估计：

a) 完整样本情形的分析；
b) Buck’s方法。基于完整样本，通过线性回归给定 $Y_1$ 插补 $Y_2$ 的条件均值（c)基于此问，这里忽略此问）；
c) 基于正态模型的随机回归插补，其中，为b)中的每个条件均值添加随机正态偏差 $N(0,s_{22.1}^2)$ ；
d) Hot-deck插补，通过基于 $Y_1$ 分布的四分位数对完整样本进行归类，进而按照这个归类，对有缺失的变量中缺失样本进行插补。

二、解答

首先我们还是按照第一章作业，生成数据。

# 生成数据
GenerateData <- function(a = 0, b = 0, seed = 2018) {
  set.seed(seed)
  z1 <- rnorm(100)
  z2 <- rnorm(100)
  z3 <- rnorm(100)

  y1 <- 1 + z1
  y2 <- 5 + 2 * z1 + z2

  u <- a * (y1 - 1) + b * (y2 - 5) + z3
  m2 <- 1 * (u < 0)

  y2_na <- y2
  y2_na[u < 0] <- NA
  # y2_na[as.logical(m2)] <- NA

  dat_comp <- data.frame(y1 = y1, y2 = y2)
  dat_incomp <- data.frame(y1 = y1, y2 = y2_na)

  return(list(dat_comp = dat_comp, dat_incomp = dat_incomp))
}

1) a = 0, b = 0

为了更好的比较各种插补方法的优劣，这里通过改变随机种子的方式，产生10个不同的数据，并以10个不同的数据来分析比较各种方法的优劣。

a) 完整样本情形

RepGenDat = function(a, b, seed = seed) {
  dat_all = GenerateData(a = a, b = a, seed = seed)
  
  # 均值
  y2_mean = mean(dat_all$dat_comp$y2)
  # 方差
  y2_var = var(dat_all$dat_comp$y2)
  
  return(c(y2_mean = round(y2_mean, 3), y2_var = round(y2_var, 3)))
}

(rep_dat_10 = sapply(1:10, function(x) RepGenDat(a = 0, b = 0, seed = x)))

上面通过修改随机种子，产生了10份不同的数据（列），第一行表示 $Y_2$ 的均值，第二行表示其方差。

c) 基于正态模型的随机回归插补

首先构造一个函数，我们对缺失数据进行填补，并对填补后 $y_2$ 的均值和方差进行估计。

StoRegImp = function(dat_all, seed = 2018) {
  set.seed(seed)
  
  dat_comp = dat_all$dat_comp
  dat_incomp = dat_all$dat_incomp
  lm_model = lm(y2 ~ y1, data = na.omit(dat_incomp))
  
  n = nrow(dat_incomp)
  r = nrow(na.omit(dat_incomp))
  s_22.1 = sum(lm_model$residuals ^ 2) / r
  
  # 找出y2缺失对应的那部分data
  na_ind = is.na(dat_incomp$y2)
  na_dat = dat_incomp[na_ind, ]
  
  new_value = predict(lm_model, na_dat)
  
  # 将缺失数据进行填补
  dat_incomp[na_ind, 'y2'] = new_value + rnorm(n - r, sd = sqrt(s_22.1))
  
  # y2的均值与方差
  y2_mean = mean(dat_incomp$y2)
  y2_var = var(dat_incomp$y2)
  
  return(c(y2_mean = y2_mean, y2_var = y2_var))
}

由于填补具有随机性。通过一次填补，很难得到一个让人信服的结果，所以我们重复100次，并计算出两个估计的均值与标准差，以便后续多种方法的比较与分析。

RepGenDat_Imp = function(a = 0, b = 0, seed_dat = seed_dat, fun = StoRegImp, B = 100) {
  dat_all = GenerateData(a = a, b = b, seed = seed_dat)
  result_B = sapply(1:B, function(i) fun(dat_all, seed = i))
  result_mean = round(apply(result_B, 1, mean), 3)
  result_std = round(apply(result_B, 1, sd), 3)
  result = paste(result_mean, result_std, sep = ' ± ')
  return(result)
}

rep_dat_sto_reg_10 = sapply(1:10, function(x) RepGenDat_Imp(a = 0, b = 0, seed_dat = x, fun = StoRegImp))
row.names(rep_dat_sto_reg_10) = c('随机回归均值估计', '随机回归方差估计')
rbind(rep_dat_10, rep_dat_sto_reg_10)

比较10次数据的生成后，进行随机回归填补的均值与方差估计。发现 $a = 0, b = 0$ 的情况，线性回归添加噪声项的方法估计均值与方差均较为准确。

下面我们再来关注Hot-deck插补：

扫描二维码关注公众号，回复： 4304859 查看本文章

d) Hot-deck插补

这里具体的做法是先利用 $Y_1$ 的四分位数将样本归为4类，然后我们再按照4类中完整的 $Y_2$ 样本随机插补其缺失的样本。

HotDeckImpY2 = function(dat_incomp, group) {
  y2_group = dat_incomp[dat_incomp$quantile_group == group, ]
  ind_na = is.na(y2_group$y2)
  len_na = sum(ind_na)
  
  # 用有值的样本插补缺失的样本
  y2_group$y2[ind_na] = sample(y2_group$y2[!ind_na], len_na, replace = TRUE)
  return(y2_group$y2)
}

HotDeckImp = function(dat_all, seed = 2018) {
  dat_incomp = dat_all$dat_incomp
  quantile_y1 = quantile(dat_incomp$y1)
  dat_incomp$quantile_group = as.numeric(cut(dat_incomp$y1, breaks = c(quantile_y1[1] - 1, quantile_y1[2:5])))
  y2_imp = unlist(lapply(1:4, function(group) HotDeckImpY2(dat_incomp, group)))
  y2_mean = mean(y2_imp)
  y2_var = var(y2_imp)
  return(c(y2_mean = y2_mean, y2_var = y2_var))
}

# rep_dat_hotdeck_10 = sapply(1:10, function(x) RepGenDat_Imp(a = 0, b = 0, seed_dat = x, fun = HotDeckImp))
# row.names(rep_dat_hotdeck_10) = c('Hot-Deck均值估计', 'Hot-Deck方差估计')
# rbind(rep_dat_10, rep_dat_sto_reg_10, rep_dat_hotdeck_10)

其实运行上述注释的部分可以汇总查看结果，但是由于后面我们还需要关注 $a = 2, b = 0$ 以及 $a = 0, b = 2$ 这两种情况，所以我们先整合成一个函数，然后再通过这个函数来看最终10次数据生成展示的结果。

SummaryAll = function(a = 0, b = 0, rep = 10, B = 100) {
  rep_dat = sapply(1:rep, function(x) RepGenDat(a = a, b = b, seed = x))
  rep_dat_sto_reg = sapply(1:rep, function(x) RepGenDat_Imp(a = a, b = b, seed_dat = x, fun = StoRegImp, B = 100))
  rep_dat_hotdeck = sapply(1:rep, function(x) RepGenDat_Imp(a = a, b = b, seed_dat = x, fun = HotDeckImp, B = 100))
  
  result_all = rbind(rep_dat, rep_dat_sto_reg, rep_dat_hotdeck)
  row.names(result_all) = c('完整数据y2均值', '完整数据y2方差', '随机回归均值估计', '随机回归方差估计', 'Hot-Deck均值估计', 'Hot-Deck方差估计')
  colnames(result_all) = paste0('第', 1:rep, '次模拟')
  return(result_all)
}

SummaryAll()

通过上表中两种方法与原始完整数据之间的比较我们可以发现：当 $a = 0, b = 0$ （MCAR），随机回归插补均值与Hot-Deck插补均值估计两者相差不多。但对方差的估计，Hot-Deck插补之后的波动较大，表现的没有随机回归插补方差估计的好。

2) a = 2, b = 0

SummaryAll(a = 2, b = 0, rep = 1, B = 100)

接着我们考虑 $a = 2, b = 0$ （NAR）。注意这里取rep = 1，而不是为10，是因为此种情况是NAR，如果取10，有可能对某种数据在进行Hot-deck进行插补时，某一个group全部是NA，这样就没有办法进行填补，从而就会出错。同样的 $a = 0, b = 2$ 也是一种NAR的缺失，所以也只用一个数据来看。

从上面的结果可以看出，Hot-Deck方法估计的均值与方差会比回归后随机化插补的均值与方差的估计要差。并且方法估计会偏小，这也是比较容易理解的。因为我们就从现有数据中选择进行插补，未添加随机扰动，方差会比真实情况要小一些。

3) a = 0, b = 2

SummaryAll(a = 0, b = 2, rep = 1, B = 100)

接着我们再来考虑 $a = 0, b = 2$ （NAR）的情况。同上面一种情况，Hot-Deck方法估计结果，无论是均值还是方差，都要略逊色于回归后随机化插补方法。注意到，这时回归后随机化插补方法估计的方差也远远小于真实的方差。因为这种删失完全依赖于 $Y_2$ 具体的值，原本的波动较大，但缺失这部分数据后，波动会变小很多，此时再用这种情况插补，及时加了扰动项，也还是远小于真实的方差。

最后，d) Hot-Deck方法虽然在这种模拟中表现的效果差于c) 随机化线性回归插补的方法，但这是由于我们的模拟数据是线性构造的原因。如果我们用非线性的方法（二次、三次、指数函数等）产生数据，则可能Hot-Deck方法会更有优势。

插补缺失数据的几种方法：《Statistical Analysis with Missing Data》习题4.15