缺失数据构造置信区间：《Statistical Analysis with Missing Data》习题7.9

一、题目

7.9

依题意，我们用下述方法生成模拟数据：
$$y_{i1}=z_{i1}$$
$$y_{i2}=z_{i1}+z_{i2}$$
其中$Z_1$、$Z_2$均服从标准正态分布，$i=1，...，20$。

缺失数据我们按照下述方法进行生成：
若$y_{i1}<0$，则$y_{i2}$缺失的概率为$0.2$；若$y_{i1}\ge 0$，则$y_{i2}$缺失的概率为$0.2$

我们将进行如下几种操作：
a）构造一个检验来检验删失是否为MCAR，并用于构造的数据集。
b）通过后面三种方法来计算${\mu }_2$的$95$%置信区间，并比较效果。（i）完整的数据；（ii）有缺失值的数据；（iii）用$t$分布近似来构造置信区间。

---

二、解答

a）构造一个检验来检验删失是否为MCAR，并用于构造的数据集

首先载入依赖包：

library(tidyr)    # 绘图所需
library(ggplot2)  # 绘图所需

构建生成数据函数。

# 生成数据
GenerateData <- function(n = 20) {
  z <- matrix(rnorm(n * 2), nrow = 2)
  
  y1 <- z[1, ]
  y2 <- z[1, ] + z[2, ]
  
  ind_na1 <- sample(which(y1 < 0), round(length(which(y1 < 0)) * 0.2))
  ind_na2 <- sample(which(y1 >= 0), round(length(which(y1 >= 0)) * 0.8))
  
  y2_na <- y2
  y2_na[c(ind_na1, ind_na2)] <- 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))
}

接着，再展现缺失出具与未缺失数据的分布情况，来决定使用什么检验。若近似正态则使用t-检验，若分布非正态，则使用非参数wilcoxon-检验。

PlotTwoDistribution <- function(dat_incomp) {
  
  y1 <- dat_incomp$y1
  y1_na <- y1
  y1_na[is.na(dat_incomp$y2)] <- NA
  dat_plot <- data.frame(`y2未缺失` = y1, `y2缺失` = y1_na)
  
  p <- dat_plot %>%
    gather(`y2未缺失`, `y2缺失`, key = "var", value = "value") %>%
    ggplot(aes(x = value)) +
    geom_histogram(aes(fill = factor(var), y = ..density..),
                   alpha = 0.3, colour = 'black') +
    stat_density(geom = 'line', position = 'identity', size = 1.5,
                 aes(colour = factor(var))) +
    facet_wrap(~ var, ncol = 2) +
    labs(y = '直方图与密度曲线', x = '值',
         title = '两种数据y1的分布', fill = '变量') +
    theme(plot.title = element_text(hjust = 0.5)) +
    guides(color = FALSE)
  
  return(p)
}

# 看看两种不同数据y1的分布情况
dat_incomp <- GenerateData()$dat_incomp
PlotTwoDistribution(dat_incomp)

由上图可以看出，由于样本量较少，不服从正态分布，所以实际的检验我们用非参数的检验会更好。不过下面我们两种检验都会进行。

这里构建进行重复test所需的函数，并同时进行t-检验与wilcoxon-检验，这里我们只看两种检验的p值。

MyTest <- function(dat = dat_incomp, method = 't.test') {
  my_test <- get(method)(na.omit(dat)$y1, dat$y1)
  p <- my_test$p.value
  return(p)
}

RepSimTest <- function(seed = 2018, n = 20) {
  set.seed(seed)
  dat_incomp <- GenerateData(n = n)$dat_incomp
  t_result <- MyTest(dat_incomp, method = 't.test')
  wilcox_result <- MyTest(dat_incomp, method = 'wilcox.test')
  return(c(t = t_result, wilcox = wilcox_result))
}

下面重复100次实验：

# 重复100次
mat_t_wilcox <- sapply(1:100, RepSimTest)
cat('重复100次两种检验，p值小于0.05的次数：\n')
rowSums(mat_t_wilcox < 0.05)
cat('重复100次两种检验，p值的平均：\n')
rowMeans(mat_t_wilcox)

由两个检验结果可以发现，即使我们重复了100次，也并没有充足的理由来拒绝假设，即通过结果发现貌似是MCAR，只是p值平均都偏小。

但由于我们实际生成数据时知道，我们并不是MCAR，所以进一步思考，怀疑出现这种结果是由于样本量$n=20$太小，故我们设置$n=100$，再看看检验情况。

# 重复100次
mat_t_wilcox <- sapply(1:100, RepSimTest, n = 100)
cat('重复100次两种检验，p值小于0.05的次数：\n')
rowSums(mat_t_wilcox < 0.05)
cat('重复100次两种检验，p值的平均：\n')
rowMeans(mat_t_wilcox)

发现前面检验不显著确实是样本量过小的问题。实际上我们的缺失是并非是MCAR，样本量增加后我们还是可以检验而出的。所以今后需要注意，在样本量过小时，很多检验并不靠谱，需要观察数据本身来寻找差异。

b）通过三种方法来计算95%置信区间，并比较效果

后面我们将用三种方法来计算${\mu }_2$的$95$置信区间，并比较效果。（i）完整的数据；（ii）有缺失值的数据；（iii）用$t$分布近似来构造置信区间（同样我们也分别针对有缺失与无缺失的数据来进行比较）。

首先我们进行相关函数的构造

CalculateMissVar <- function(dat_incomp = dat_incomp) {
  y1 <- dat_incomp$y1
  y2 <- dat_incomp$y2
  dat_incomp_ <- na.omit(dat_incomp)
  y1_ <- dat_incomp_$y1
  y2_ <- dat_incomp_$y2
  
  n <- length(y2)
  r <- length(y2_)
  
  mu1 <- mean(y1)
  y1_bar <- mean(y1_)
  y2_bar <- mean(y2_)
  s11 <- var(y1_) * (r - 1) / r
  s22 <- var(y2_) * (r - 1) / r
  s12 <- cov(y1_, y2_) * (r - 1) / r
  
  sigma22.1 <- s22 - s12 ^ 2 / s11
  
  beta21.1 <- s12 / s11
  beta20.1 <- y2_bar - beta21.1 * y1_bar
  
  sigma11_hat <- var(y1) * (n - 1) / n
  sigma22_hat <- s22 + beta21.1 ^ 2 * (sigma11_hat - s11)
  
  rho <- (s12 * (s11 * s22) ^ (-1/2)) * ((sigma11_hat / s11) * (s22 / sigma22_hat)) ^ (1/2)
  
  return(sigma22.1 * (1 / r + rho ^ 2 / n / (1 - rho ^ 2) + (y1_bar - mu1) ^ 2 / r / s11))
}

CalculateCI <- function(n = 20, deleted = FALSE, t.dis = FALSE) {
  
  dat_all <- GenerateData(n = n)
  dat_comp <- dat_all$dat_comp
  dat_incomp <- dat_all$dat_incomp
  r <- length(na.omit(dat_all$dat_incomp$y2))
  
  if (t.dis == FALSE) {
    quan <- qnorm(0.975)
  } else {
    quan <- qt(0.975, df = r - 1)
  }
  
  if (deleted == FALSE) {
    y2 <- dat_all$dat_comp$y2
    ci <- c(left_value = mean(y2) - quan * sd(y2) / sqrt(n), right_value = mean(y2) + quan * sd(y2) / sqrt(n))
  } else {
    y2 <- na.omit(dat_all$dat_incomp$y2)
    dat_incomp <- dat_all$dat_incomp
    y2_sd <- sqrt(CalculateMissVar(dat_incomp))
    ci <- c(left_value = mean(y2) - quan * y2_sd, right_value = mean(y2) + quan * y2_sd)
  }
  return(ci)
}

PlotCI <- function(rep = 100, n = 20, deleted = FALSE, t.dis = FALSE) {
  
  mat_ci <- sapply(1:rep, function(x) CalculateCI(n = n, deleted = deleted, t.dis = t.dis))
  cover_times <- sum(mat_ci[1, ] * mat_ci[2, ] < 0)
  
  ind <- rep(seq(0, 1, length.out = rep), each = 2)
  value <- matrix(mat_ci, ncol = 1)
  group <- rep(1:rep, each = 2)
  in_ci <- rep(mat_ci[1, ] * mat_ci[2, ] < 0, each = 2)
  
  dat_ci <- data.frame(ind, value, group, in_ci)
  
  p <- ggplot(dat = dat_ci) +
    geom_line(aes(x = ind, y = value, group = group, color = in_ci), size = 1) +
    geom_hline(yintercept = 0, size = 1) + 
    labs(y = '置信区间', x = paste0(rep, '次'),
         title = paste0('重复', rep, '次，覆盖次数为：', cover_times)) +
    theme_bw() + theme(panel.grid = element_blank(), 
                       axis.text = element_blank(),
                       axis.ticks = element_blank(),
                       axis.title = element_blank(),
                       panel.border = element_blank(),
                       plot.title = element_text(hjust = 0.5),
                       legend.position = "none")
  return(p)
}

###（i）无删失 + 正态

PlotCI(200, deleted = F, t.dis = F)

（ii）删失 + 正态

PlotCI(200, deleted = T, t.dis = F)

（iii）删失 + t分布

PlotCI(200, deleted = T, t.dis = T)

（iv）无删失 + t分布

PlotCI(200, deleted = F, t.dis = T)

从上面四种情况发现（题目要求应该是前三种，后面自己补了第四种），第一种“无删失+正态”的情况，发现置信区间相对较准；但第二种“有删失+正态”的情况，置信区间的覆盖频率在70%左右，相对来说差了一些；第三种情况“有删失+t分布”，相比第二种，效果又有了一定的提升，因为样本量本身就小，并且还删失了接近一半的值，所以用t分布的分位数来构造置信区间效果更好；至于最后一种“无删失+t分布”的情况，只是“画蛇添足”加上去的，发现效果更差，因为我们本身的例子就是用正态分布构造的。

错误的方法

最后补一下之前做错的方法：没有用极大似然估计，针对缺失数据直接使用sd函数来计算标准差。这样做会发现第二种与第三种效果都很差，覆盖频率在60%左右，达不到用极大似然估计出来的结果。

下面放上之前错误的第二第三种情况：

CalculateCI <- function(n = 20, deleted = FALSE, t.dis = FALSE) {
  
  dat_all <- GenerateData(n = n)
  dat_comp <- dat_all$dat_comp
  dat_incomp <- dat_all$dat_incomp
  r <- length(na.omit(dat_all$dat_incomp$y2))
  
  if (t.dis == FALSE) {
    quan <- qnorm(0.975)
  } else {
    quan <- qt(0.975, df = r - 1)
  }
  
  if (deleted == FALSE) {
    y2 <- dat_all$dat_comp$y2
    ci <- c(left_value = mean(y2) - quan * sd(y2) / sqrt(n), right_value = mean(y2) + quan * sd(y2) / sqrt(n))
  } else {
    y2 <- na.omit(dat_all$dat_incomp$y2)
    ci <- c(left_value = mean(y2) - quan * sd(y2) / sqrt(n), right_value = mean(y2) + quan * sd(y2) / sqrt(n))
  }
  return(ci)
}

（ii）删失 + 正态

PlotCI(200, deleted = T, t.dis = F)

（iii）删失 + t分布

PlotCI(200, deleted = T, t.dis = T)