11.4 Imputación por regresión

La imputación por regresión es una técnica de análisis de datos que se utiliza para imputar valores faltantes en un conjunto de datos. Esta técnica se basa en la construcción de un modelo de regresión a partir de las variables \(X\) disponibles en el conjunto de datos, que se utiliza para predecir los valores faltantes \(Y\). Cuando se habla de predicción no se refiere a dar un valor futuro, se refiere a dar un valor a la información faltante.

Para llevar a cabo la imputación por regresión, se selecciona una variable objetivo que tenga valores faltantes y se identifican las variables predictoras que tienen una correlación significativa con la variable objetivo. Se ajusta un modelo de regresión utilizando las variables predictoras y la variable objetivo disponible, y se utilizan los coeficientes del modelo para predecir los valores faltantes de la variable objetivo.

Es importante destacar que la imputación por regresión es una técnica estadística avanzada que requiere conocimientos sólidos de análisis de datos y modelado estadístico. Además, su aplicación puede verse limitada por la calidad y la cantidad de los datos disponibles y por la distribución de los valores faltantes en el conjunto de datos. Por lo tanto, es importante utilizarla con precaución y tener en cuenta sus limitaciones.

Para ejemplificar, imputemos la variable ingreso y la variable empleados tomadno como covariables las variable zona, sexo y empleamiento. Para la primera variable se utiliza un modelo de regresión líneal múltiple y para el segundo. se utiliza un modelo multinomial (dada la naturaleza de la variable) como se muestra a continución:

require(nnet)

## Loading required package: nnet

encuesta$Income_imp <- encuesta$Income_missin
encuesta$Employment_imp <- encuesta$Employment_missin
encuesta_obs <- filter(encuesta, !is.na(Income_missin))
encuesta_no_obs <- filter(encuesta, is.na(Income_missin))
mod <- lm(Income~Zone + Sex +Expenditure, data = encuesta_obs)
mod.mult <- multinom(Employment~Zone + Sex +Expenditure, data = encuesta_obs)

## # weights:  15 (8 variable)
## initial  value 1651.214270 
## iter  10 value 1182.110113
## final  value 1132.682019 
## converged

Una vez ajustado los modelos tanto para las variable ingreso como para empleados, se realiza el proceso de predicción como se muestra a continuación:

imp <- predict(mod, encuesta_no_obs)
imp.mult <- predict(mod.mult, encuesta_no_obs, type =  "class")
encuesta_no_obs$Income_imp <- imp
encuesta_no_obs$Employment_imp <- imp.mult
encuesta <- bind_rows(encuesta_obs,encuesta_no_obs)

A continuación, se presenta el porcentaje de datos faltantes en la variable empleado:

prop.table(table(encuesta$Employment_missin, useNA = "a"))

Unemployed	Inactive	Employed	NA
0.0340607	0.2990953	0.4667376	0.2001064

Se puede observar que hay un 20% de datos faltantes. Una vez se realiza la imputación, se redistribuyen esas observaciones en las demás categorías arrojando los siguientes resultados:

prop.table(table(encuesta$Employment_imp, useNA = "a"))

Unemployed	Inactive	Employed	NA
0.0340607	0.3858435	0.5800958	0

A modo de ejercicio, se realiza el cálculo del porcentaje de los valores faltante para la variable empleados por zona, antes y después de imputar, reconociendo que, los porcentajes marginales por zona no varían:

library(printr)
library(kableExtra)

kable(prop.table( table(encuesta$Zone, encuesta$Employment_missin, useNA = "a")) %>%               addmargins())

	Unemployed	Inactive	Employed	NA	Sum
Rural	0.0117084	0.1506120	0.2208622	0.1005854	0.483768
Urban	0.0223523	0.1484832	0.2458755	0.0995210	0.516232
NA	0.0000000	0.0000000	0.0000000	0.0000000	0.000000
Sum	0.0340607	0.2990953	0.4667376	0.2001064	1.000000

kable(
prop.table( table(encuesta$Zone, encuesta$Employment_imp,useNA = "a")) %>% addmargins()
)

	Unemployed	Inactive	Employed	NA	Sum
Rural	0.0117084	0.2006386	0.2714210	0	0.483768
Urban	0.0223523	0.1852049	0.3086748	0	0.516232
NA	0.0000000	0.0000000	0.0000000	0	0.000000
Sum	0.0340607	0.3858435	0.5800958	0	1.000000

El mismo ejercicio anterior se realiza por sexo arrojando los siguientes resultados:

kable(
  prop.table( table(encuesta$Sex, encuesta$Employment_missin, useNA = "a")) %>% addmargins()
)

	Unemployed	Inactive	Employed	NA	Sum
Female	0.0106440	0.2277807	0.2011708	0.0989888	0.5385844
Male	0.0234167	0.0713145	0.2655668	0.1011176	0.4614156
NA	0.0000000	0.0000000	0.0000000	0.0000000	0.0000000
Sum	0.0340607	0.2990953	0.4667376	0.2001064	1.0000000

kable(
prop.table( table(encuesta$Sex, encuesta$Employment_imp,useNA = "a")) %>% addmargins()
)

	Unemployed	Inactive	Employed	NA	Sum
Female	0.0106440	0.3145290	0.2134114	0	0.5385844
Male	0.0234167	0.0713145	0.3666844	0	0.4614156
NA	0.0000000	0.0000000	0.0000000	0	0.0000000
Sum	0.0340607	0.3858435	0.5800958	0	1.0000000

Para finalizar y como se ha realizado con los métodos anteriores, se hace el cálculo de la variable ingreso completa e imputada:

encuesta %>% summarise(
  Income_ = mean(Income),
  Income_sd = sd(Income),
  Income_imp_ = mean(Income_imp),
  Income_imp_sd = sd(Income_imp))

Income_	Income_sd	Income_imp_	Income_imp_sd
604.2494	513.1078	611.7477	498.3293

Teniendo un sesgo relativo de 1.2%.

100*(604.2494 - 611.7477)/604.2494

## [1] -1.240928

Haciendo el mismo ejercicio por zona tenemos:

encuesta %>%group_by(Zone) %>%  summarise(
  Income_ = mean(Income),
  Income_sd = sd(Income),
  Income_imp_ = mean(Income_imp),
  Income_imp_sd = sd(Income_imp))

Zone	Income_	Income_sd	Income_imp_	Income_imp_sd
Rural	469.1217	336.5861	476.1361	317.3999
Urban	730.8793	609.0304	738.8311	594.5319

Con sesgos relativos para la zona rural de 1.5% y para urbano de 1%.

100*(469.1217 - 476.1361)/469.1217

## [1] -1.49522

100*(730.8793 - 738.8311)/730.8793

## [1] -1.087977

Para la variable sexo, se puede realizar el mismo ejercicio anterior. Se le deja al lector hacer los cálculos pertinentes:

encuesta %>%group_by(Sex) %>%  summarise(
  Income_ = mean(Income),
  Income_sd = sd(Income),
  Income_imp_ = mean(Income_imp),
  Income_imp_sd = sd(Income_imp))

Sex	Income_	Income_sd	Income_imp_	Income_imp_sd
Female	589.2330	504.3041	598.6515	488.3917
Male	621.7771	522.9428	627.0341	509.5410

Por último, los ejercicios gráficos se realizan a continuación:

dat_plot7 <- tidyr::gather(
  encuesta %>% dplyr::select(Zone,Sex,Income, Income_imp),
  key = "Caso", value = "Income2", -Zone,-Sex)

p1 <- ggplot(dat_plot7, aes(x = Income2, fill = Caso)) + 
  geom_density(alpha = 0.2) + theme_bw() +
   theme(legend.position = "bottom") +
  geom_vline(
    xintercept = mean(encuesta$Income), 
             col = "red") +
  geom_vline(
    xintercept = mean(encuesta$Income_imp), 
             col = "blue")
p1

p1 <- ggplot(dat_plot7, aes(x= Caso, y = Income2)) + 
   geom_hline(yintercept = mean(encuesta$Income),
              col = "red") +  geom_boxplot() +
  facet_grid(Zone~Sex) + theme_bw()
p1

Obteniendo buenos resultados en el proceso de imputación como se pudo observar en las gráficas anteriores.