R - 多重插补前的部分均值插补
R - Partial mean imputation before multiple imputation
我有一个 100 行、200 个变量的数据集（主要是李克特量表调查数据作为因子，但也有一些数值数据）。我在下面附上了一个具有类似缺失数据模式的代表；一些空白单元格是零星的，但对于某些行，整个刻度都是空白的。
我想在 子量表计算之前使用 mice 包的多重插补 ，但是因子密集的数据集的多重插补是不切实际的。但是，我需要在计算子量表总计之前解决偶尔缺失的单元格，因为如果量表中的一个项目是 NA，那么子量表总计也将是 NA。
我的目标是对偶尔缺失的因子单元格进行single/mean插补，然后计算子量表总计，然后对数字子量表总变量进行多重插补，这将针对剩余的大差距。
我希望用个体剩余尺度变量的平均值来估算偶尔缺失的值。例如，如果一个人缺失 df$c2，则该缺失值将由 c1、c3、c4 和 c5 的平均值估算。
如何根据每行中的缺失模式对数据子集进行 single/mean 插补？
library(reprex)
library(tidyverse)
library(missMethods)
library(finalfit)
library(mice)
set.seed(1234)
a1 <- sample(1:3, 2000, replace=TRUE)
a2 <- sample(1:3, 2000, replace=TRUE)
a3 <- sample(1:3, 2000, replace=TRUE)
a4 <- sample(1:3, 2000, replace=TRUE)
a5 <- sample(1:3, 2000, replace=TRUE)
b1 <- sample(1:3, 2000, replace=TRUE)
b2 <- sample(1:3, 2000, replace=TRUE)
b3 <- sample(1:3, 2000, replace=TRUE)
b4 <- sample(1:3, 2000, replace=TRUE)
b5 <- sample(1:3, 2000, replace=TRUE)
c1 <- sample(1:3, 2000, replace=TRUE)
c2 <- sample(1:3, 2000, replace=TRUE)
c3 <- sample(1:3, 2000, replace=TRUE)
c4 <- sample(1:3, 2000, replace=TRUE)
c5 <- sample(1:3, 2000, replace=TRUE)
d1 <- sample(1:3, 2000, replace=TRUE)
d2 <- sample(1:3, 2000, replace=TRUE)
d3 <- sample(1:3, 2000, replace=TRUE)
d4 <- sample(1:3, 2000, replace=TRUE)
d5 <- sample(1:3, 2000, replace=TRUE)
years <- sample(18:70, 2000, replace=TRUE)
gender <- sample(c("male","female"), 2000, replace=TRUE, prob=c(0.5, 0.5))
education <- sample(c("highschool","college", "gradschool"), 2000, replace=TRUE, prob=c(1/3, 1/3, 1/3))
height <- sample(60:75, 2000, replace=TRUE)
df <- data.frame(a1, a2, a3, a4, a5,
b1, b2, b3, b4, b5,
c1, c2, c3, c4, c5,
d1, d2, d3, d4, d5,
years, gender, education, height)
facts <- df %>% select(contains("gender") | contains ("education")) %>% colnames()
cols <- df %>% select(ends_with("1") |
ends_with("2") |
ends_with("3") |
ends_with("4") |
ends_with("5")) %>% colnames()
df <- delete_MCAR(df, p = 0.01, cols_mis = cols) %>%
dplyr::mutate(across(all_of(facts), factor))
df[c(200:300, 500:550, 900:1000), 1:5] <- NA
df[c(400:500, 600:650, 1100:1200), 6:10] <- NA
df[c(10:100, 300:450, 1500:1650), 11:15] <- NA
df[c(300:400, 700:800, 1700:1900), 16:20] <- NA
## I think mean imputation of the sporadically-missing cells would occur here
missing_plot(df)
df <- df %>%
rowwise() %>%
mutate(a_mean = mean(c(a1, a2, a3, a4, a5))) %>%
mutate(b_mean = mean(c(b1, b2, b3, b4, b5))) %>%
mutate(c_mean = mean(c(c1, c2, c3, c4, c5))) %>%
mutate(d_mean = mean(c(d1, d2, d3, d4, d5)))
df <- df %>%
select(ends_with("mean") | contains("years") | contains("gender") | contains("education") | contains("height"))
imp_df <- mice::mice(df, m = 5, print = FALSE)
com <- mice::complete(imp_df)
我的理解是否正确，您只想对每个 a1 ... d5 单独取 mean，仅在缺失值偶尔缺失的情况下？然后我们可以定义一个函数来筛选以识别小于特定长度的连续 NA 值。我的方法基于 this great post.
下面的 df 正是您认为应该出现的地方。
na_search <- function(x, threshold = 5) {
run <- rle(is.na(x))
run$values <- run$values & (run$length <= threshold)
inverse.rle(run)
}
df %>%
mutate(across(
matches("[a-z][1-9]"),
~ ifelse(na_search(.x), mean(.x, na.rm = T), .x)
)) %>%
missing_plot()
用其他尺度变量的平均值填充
如果我们想填充其他比例变量，我们采用类似的方法。只是一些注意事项：
- 我们需要从
rowwise() 尺度均值中删除缺失值，因为否则它就是 NA 我们有缺失值的任何地方，我们无论如何都无法进行任何插补。
- 我们应该在使用
rowwise() 之后总是 ungroup() 否则很容易忘记和 return 奇怪的结果。
- 我们将使用
across() 的一些功能来访问 cur_column() 名称，对字母进行子集化，并获取 .data 中的相关 x_mean 列。
- 定义一个
infill_fun()来做上面的换行na_search().
df <- df %>%
rowwise() %>%
mutate(a_mean = mean(c(a1, a2, a3, a4, a5), na.rm = T)) %>%
mutate(b_mean = mean(c(b1, b2, b3, b4, b5), na.rm = T)) %>%
mutate(c_mean = mean(c(c1, c2, c3, c4, c5), na.rm = T)) %>%
mutate(d_mean = mean(c(d1, d2, d3, d4, d5), na.rm = T)) %>%
ungroup()
infill_fun <- function(x, threshold, df, cur_col) {
mean_col <- paste0(substr(cur_col, 1, 1), "_mean")
ifelse(na_search(x, threshold),
df[[mean_col]],
x)
}
df %>%
mutate(across(
matches("[a-z][1-9]"),
~ infill_fun(
.x,
threshold = 5,
df = .data,
cur_col = cur_column()
)
)) %>%
missing_plot()
我有一个 100 行、200 个变量的数据集（主要是李克特量表调查数据作为因子，但也有一些数值数据）。我在下面附上了一个具有类似缺失数据模式的代表；一些空白单元格是零星的，但对于某些行，整个刻度都是空白的。
我想在 子量表计算之前使用 mice 包的多重插补 ，但是因子密集的数据集的多重插补是不切实际的。但是，我需要在计算子量表总计之前解决偶尔缺失的单元格，因为如果量表中的一个项目是 NA，那么子量表总计也将是 NA。
我的目标是对偶尔缺失的因子单元格进行single/mean插补，然后计算子量表总计，然后对数字子量表总变量进行多重插补，这将针对剩余的大差距。
我希望用个体剩余尺度变量的平均值来估算偶尔缺失的值。例如，如果一个人缺失 df$c2，则该缺失值将由 c1、c3、c4 和 c5 的平均值估算。
如何根据每行中的缺失模式对数据子集进行 single/mean 插补？
library(reprex)
library(tidyverse)
library(missMethods)
library(finalfit)
library(mice)
set.seed(1234)
a1 <- sample(1:3, 2000, replace=TRUE)
a2 <- sample(1:3, 2000, replace=TRUE)
a3 <- sample(1:3, 2000, replace=TRUE)
a4 <- sample(1:3, 2000, replace=TRUE)
a5 <- sample(1:3, 2000, replace=TRUE)
b1 <- sample(1:3, 2000, replace=TRUE)
b2 <- sample(1:3, 2000, replace=TRUE)
b3 <- sample(1:3, 2000, replace=TRUE)
b4 <- sample(1:3, 2000, replace=TRUE)
b5 <- sample(1:3, 2000, replace=TRUE)
c1 <- sample(1:3, 2000, replace=TRUE)
c2 <- sample(1:3, 2000, replace=TRUE)
c3 <- sample(1:3, 2000, replace=TRUE)
c4 <- sample(1:3, 2000, replace=TRUE)
c5 <- sample(1:3, 2000, replace=TRUE)
d1 <- sample(1:3, 2000, replace=TRUE)
d2 <- sample(1:3, 2000, replace=TRUE)
d3 <- sample(1:3, 2000, replace=TRUE)
d4 <- sample(1:3, 2000, replace=TRUE)
d5 <- sample(1:3, 2000, replace=TRUE)
years <- sample(18:70, 2000, replace=TRUE)
gender <- sample(c("male","female"), 2000, replace=TRUE, prob=c(0.5, 0.5))
education <- sample(c("highschool","college", "gradschool"), 2000, replace=TRUE, prob=c(1/3, 1/3, 1/3))
height <- sample(60:75, 2000, replace=TRUE)
df <- data.frame(a1, a2, a3, a4, a5,
b1, b2, b3, b4, b5,
c1, c2, c3, c4, c5,
d1, d2, d3, d4, d5,
years, gender, education, height)
facts <- df %>% select(contains("gender") | contains ("education")) %>% colnames()
cols <- df %>% select(ends_with("1") |
ends_with("2") |
ends_with("3") |
ends_with("4") |
ends_with("5")) %>% colnames()
df <- delete_MCAR(df, p = 0.01, cols_mis = cols) %>%
dplyr::mutate(across(all_of(facts), factor))
df[c(200:300, 500:550, 900:1000), 1:5] <- NA
df[c(400:500, 600:650, 1100:1200), 6:10] <- NA
df[c(10:100, 300:450, 1500:1650), 11:15] <- NA
df[c(300:400, 700:800, 1700:1900), 16:20] <- NA
## I think mean imputation of the sporadically-missing cells would occur here
missing_plot(df)
df <- df %>%
rowwise() %>%
mutate(a_mean = mean(c(a1, a2, a3, a4, a5))) %>%
mutate(b_mean = mean(c(b1, b2, b3, b4, b5))) %>%
mutate(c_mean = mean(c(c1, c2, c3, c4, c5))) %>%
mutate(d_mean = mean(c(d1, d2, d3, d4, d5)))
df <- df %>%
select(ends_with("mean") | contains("years") | contains("gender") | contains("education") | contains("height"))
imp_df <- mice::mice(df, m = 5, print = FALSE)
com <- mice::complete(imp_df)
我的理解是否正确，您只想对每个 a1 ... d5 单独取 mean，仅在缺失值偶尔缺失的情况下？然后我们可以定义一个函数来筛选以识别小于特定长度的连续 NA 值。我的方法基于 this great post.
下面的 df 正是您认为应该出现的地方。
na_search <- function(x, threshold = 5) {
run <- rle(is.na(x))
run$values <- run$values & (run$length <= threshold)
inverse.rle(run)
}
df %>%
mutate(across(
matches("[a-z][1-9]"),
~ ifelse(na_search(.x), mean(.x, na.rm = T), .x)
)) %>%
missing_plot()
用其他尺度变量的平均值填充
如果我们想填充其他比例变量，我们采用类似的方法。只是一些注意事项：
- 我们需要从
rowwise()尺度均值中删除缺失值，因为否则它就是NA我们有缺失值的任何地方，我们无论如何都无法进行任何插补。 - 我们应该在使用
rowwise()之后总是ungroup()否则很容易忘记和 return 奇怪的结果。 - 我们将使用
across()的一些功能来访问cur_column()名称，对字母进行子集化，并获取.data中的相关x_mean列。 - 定义一个
infill_fun()来做上面的换行na_search().
df <- df %>%
rowwise() %>%
mutate(a_mean = mean(c(a1, a2, a3, a4, a5), na.rm = T)) %>%
mutate(b_mean = mean(c(b1, b2, b3, b4, b5), na.rm = T)) %>%
mutate(c_mean = mean(c(c1, c2, c3, c4, c5), na.rm = T)) %>%
mutate(d_mean = mean(c(d1, d2, d3, d4, d5), na.rm = T)) %>%
ungroup()
infill_fun <- function(x, threshold, df, cur_col) {
mean_col <- paste0(substr(cur_col, 1, 1), "_mean")
ifelse(na_search(x, threshold),
df[[mean_col]],
x)
}
df %>%
mutate(across(
matches("[a-z][1-9]"),
~ infill_fun(
.x,
threshold = 5,
df = .data,
cur_col = cur_column()
)
)) %>%
missing_plot()