Dirección de Infraestructura Estadística y muestreo DINEM

ENEMDU Abril - Mayo - Junio 2024

1.- Preparación

Bases de viviendas

kable(viviendas)
Abril Mayo Junio
UPM 1288 1288 1286
Vivienda 8752 8688 8748
Hogar 8804 8727 8796 
# kable(upm_ac)
# kable(fc_ac)
# kable(ef_ac)

Bases de personas

‘r names(v1)’

kable(personas)
Abril Mayo Junio
UPM 1288 1288 1286
Vivienda 8752 8688 8748
Hogar 8804 8727 8796
Personas 28606 28432 28670 
# Guardar las bases tratadas de personas
saveRDS(p1, "./2024/Trimestrales/2_abr_jun/tratadas/personas/p1.rds")
saveRDS(p2, "./2024/Trimestrales/2_abr_jun/tratadas/personas/p2.rds")
saveRDS(p3, "./2024/Trimestrales/2_abr_jun/tratadas/personas/p3.rds")

2.- Preparación Factores Mensuales

Factores de expansión

  • Periodo 1 Abril
p1_fexp = readRDS(file = "./2024/Factores mensuales/4_Abril/FEXP_ENEMDU_T_202404.rds") %>%
  mutate(id_upm = str_pad(str_trim(id_upm, side = "both"), 12, "left", "0"),
         vivienda = str_pad(str_trim(vivienda, side = "both"), 2, "left", "0"),
         persona = str_pad(str_trim(p01, side = "both"), 2, "left", "0"),
         dominio = str_pad(str_trim(dominio, side = "both"), 2, "left", "0"),
         estrato = str_pad(str_trim(estrato, side = "both"), 4, "left", "0"),
         hogar = as.character(hogar),
         id_hog = paste0(id_upm, vivienda, hogar)) %>%
  select(id_upm, vivienda, hogar, persona, dominio, 
         estrato, fexp_teo, fexp_aju, fexp_cal_hog = fexp_cal_hi, fexp_cal_upm=fexp)
  • Periodo 2 Mayo
p2_fexp = readRDS(file = "./2024/Factores mensuales/5_Mayo/FEXP_ENEMDU_T_202405.rds") %>%
  mutate(id_upm = str_pad(str_trim(id_upm, side = "both"), 12, "left", "0"),
         vivienda = str_pad(str_trim(vivienda, side = "both"), 2, "left", "0"),
         persona = str_pad(str_trim(p01, side = "both"), 2, "left", "0"),
         dominio = str_pad(str_trim(dominio, side = "both"), 2, "left", "0"),
         estrato = str_pad(str_trim(estrato, side = "both"), 4, "left", "0"),
         hogar = as.character(hogar),
         id_hog = paste0(id_upm, vivienda, hogar)) %>%
  select(id_upm, vivienda, hogar, persona, dominio, 
         estrato, fexp_teo, fexp_aju, fexp_cal_hog= fexp_cal_hi,fexp_cal_upm=fexp)
  • Periodo 3 Junio
p3_fexp = readRDS(file = "./2024/Factores mensuales/6_Junio/FEXP_ENEMDU_T_202406.rds") %>%
  mutate(id_upm = str_pad(str_trim(id_upm, side = "both"), 12, "left", "0"),
         vivienda = str_pad(str_trim(vivienda, side = "both"), 2, "left", "0"),
         persona = str_pad(str_trim(p01, side = "both"), 2, "left", "0"),
         dominio = str_pad(str_trim(dominio, side = "both"), 2, "left", "0"),
         estrato = str_pad(str_trim(estrato, side = "both"), 4, "left", "0"),
         hogar = as.character(hogar),
         id_hog = paste0(id_upm, vivienda, hogar)) %>%
  select(id_upm, vivienda, hogar, persona, dominio, 
         estrato, fexp_teo, fexp_aju, fexp_cal_hog= fexp_cal_hi,fexp_cal_upm=fexp)
#

Al unir las tres bases con las variables necesarias tenemos:

(dim(base))
## [1] 85708    33

Analisis descriptivo de la nueva base de personas con fexp

Sexo

ggplot(a, aes(x = "", y = Por, fill = Sexo)) +
  geom_col() +
  guides(fill = guide_legend(title = "Sexo")) +
  coord_polar(theta = "y") +
  geom_text(aes(label = Por), position = position_stack(vjust = 0.5)) +
    labs(title = "Numero de personas por sexo: Abril - Mayo - Junio 2024", fill = NULL, x = NULL, y= NULL) +
  theme_void() +
   scale_fill_manual(values=c("#ADD8E6","#BFEFFF"))

Área

ggplot(b, aes(x = "", y = Por, fill = Area)) +
  geom_col() +
  guides(fill = guide_legend(title = "Area")) +
  coord_polar(theta = "y") +
  geom_text(aes(label = Por), position = position_stack(vjust = 0.5)) +
    labs(title = "Numero de personas por Area: Abril - Mayo - Junio 2024", fill = NULL, x = NULL, y= NULL) +
  theme_void() +
  scale_fill_manual(values=c("#B4CDCD","#D1EEEE"))

# ggplot(area_dom, mapping = aes(x = Dominio, y = Freq, fill = Area))+
#   geom_col() +
#   scale_fill_hue(labels = c("Urbano", "Rural")) +
#   labs(title = "Numero de personas por dominio y area : Abril - Mayo - Junio") +
#   scale_fill_manual(values = c("azure3", "lightblue"))
#   #geom_text(aes(label=Freq), vjust=1.6, color="black",
#    #         position = position_dodge(0.7),  size=4.0)
 # ggplot(mes_dom, mapping = aes(x = Dominio, y = Frecuencia, fill = Mes))+
 #   geom_col() +
 #   scale_fill_hue(labels = periodos) +
 #   labs(title = "Numero de personas por mes y dominio: Abril - Mayo - Junio") +
 #  # geom_text(aes(label=Frecuencia), vjust=1.6, color="black",
 #           #  position = position_dodge(0.5),  size=4.0)
 #  scale_fill_manual(values=c("snow3", "#BFEFFF", "#8B8386"))
# En la base final se tiene:
# kable(obs)

Factor de expansión teórico

Resumen estadistico de los factores de expansion teoricos:

summary(base$fexp_teo)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   35.62  117.86  245.79  373.60  478.44 3342.86
# Grafico
ggplot(data = base,
       mapping = aes(x = fexp_teo)) +
  geom_histogram(bins = 100,
                 position = 'identity',
                 alpha = 0.8) +
  labs(title = ' Distribución de los factores de expansión teoricos',
       x = 'fexp_teo',
       y = 'count',
       subtitle = 'Acumulada',
       caption = 'Encuesta Nacional de Empleo, Desempleo y Subempleo (ENEMDU). INEC - Ecuador.')

Factor de expansión ajustado por cobertura

summary(base$fexp_aju)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   38.25  119.14  247.50  378.72  488.55 3342.86
# Grafico
ggplot(data = base,
       mapping = aes(x = fexp_aju)) +
  geom_histogram(bins = 100,
                 position = 'identity',
                 alpha = 0.8) +
  labs(title = ' Distribución de los factores de expansión ajustados por cobertura',
       x = 'fexp_aju',
       y = 'count',
       subtitle = 'Acumulada',
       caption = 'Encuesta Nacional de Empleo, Desempleo y Subempleo (ENEMDU). INEC - Ecuador.')

# Guardar la base ENEMDU Acumulada
saveRDS(base, "./2024/Trimestrales/2_abr_jun/tratadas/personas/base_acum.rds")

3.- Calculo factor balanceado mes dominio

Calculo del factor de expansión balanceado (metodologia delta)

base = base %>%
  mutate(dom7 = ifelse(dominio == "06" | dominio == "07" | dominio == "08" | (dominio == "12" & area == 1), "06",
                       ifelse(dominio == "09" | dominio == "10" | dominio == "11" | (dominio == "12" & area == 2), "07",
                              dominio)))
table(base$dom7, useNA = "ifany")
## 
##    01    02    03    04    05    06    07 
##  8395  9122  5930  6967  4950 27309 23035
table(base$dominio, useNA = "ifany")
## 
##    01    02    03    04    05    06    07    08    09    10    11    12 
##  8395  9122  5930  6967  4950 12518 10229  4123 10594  5971  6013   896

Calculo de los deltas

El balanceo de los pesos de muestreo se realizó a través de un factor de ajuste propuesto por Kish (1999) en el contexto de acumulación de muestras y está dado por la siguiente expresión:

\[ \delta _{tD}=\frac{n_{tD}}{\sum _{t=1}^{3}n_{tD}} \]

Donde: \(\delta _{tD}\) es un factor de ajuste, que depende del tamaño de muestra, que representa el porcentaje de individuos investigados en el mes t para el dominio de estudio D.

dQ <- base %>%
  group_by(dom7, mes) %>%
  summarise(n = n()) %>%
  mutate(delta = n/sum(n))
dQ %>%
  kbl(caption = "Tabla 1: Deltas") %>%
  kable_paper("hover", full_width = F)
Tabla 1: Deltas
dom7 mes n delta
01 04 2845 0.3388922
01 05 2811 0.3348422
01 06 2739 0.3262656
02 04 3078 0.3374260
02 05 3034 0.3326025
02 06 3010 0.3299715
03 04 1976 0.3332209
03 05 1952 0.3291737
03 06 2002 0.3376054
04 04 2292 0.3289795
04 05 2376 0.3410363
04 06 2299 0.3299842
05 04 1636 0.3305051
05 05 1667 0.3367677
05 06 1647 0.3327273
06 04 9111 0.3336263
06 05 9078 0.3324179
06 06 9120 0.3339558
07 04 7668 0.3328847
07 05 7514 0.3261993
07 06 7853 0.3409160

En la Tabla 1 se muestra los deltas (ponderadores de balanceo) que se utilizarán para balancear los factores de expansión. Con esto se logra que cada mes de levantamiento de información este equitativamente representado por la información levantada. Los factores de expansión trimestrales balanceados resultan de la multiplicación del factor de expansión ajustado por cobertura de las ENEMDU mensuales por el ponderador que balancea la muestra para cada mes (delta), de la siguiente forma:

\[w_{k_b}= w_{k_a}*\delta _{tD} \]

base %<>% 
full_join(dQ, by = c("dom7", "mes")) %>% 
# Creación del factor anual inicial (normalizado)
mutate(fexp_acum_teo = fexp_teo * delta,
       fexp_acum_aju = fexp_aju * delta)

Analisis estadístico descriptivo

summary(base$delta)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.3262  0.3305  0.3329  0.3334  0.3348  0.3410

Factor de expansión teórico acumulado

summary(base$fexp_acum_teo)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.62   39.29   81.55  124.55  160.40 1116.37
# Grafico
ggplot(data = base,
       mapping = aes(x = fexp_acum_teo)) +
  geom_histogram(bins = 100,
                 position = 'identity',
                 alpha = 0.8) +
  labs(title = ' Distribución de los fexp_acum_teo',
       x = 'fexp_acum_teo',
       y = 'count',
       subtitle = 'Acumulada',
       caption = 'Encuesta Nacional de Empleo, Desempleo y Subempleo (ENEMDU). INEC - Ecuador.')

Factor de expansión acumulado ajustado por cobertura

summary(base$fexp_acum_aju)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37
# Grafico
ggplot(data = base,
       mapping = aes(x = fexp_acum_aju)) +
  geom_histogram(bins = 100,
                 position = 'identity',
                 alpha = 0.8) +
  labs(title = ' Distribución de los fexp_acum_aju',
       x = 'fexp_acum_aju',
       y = 'count',
       subtitle = 'Acumulada',
       caption = 'Encuesta Nacional de Empleo, Desempleo y Subempleo (ENEMDU). INEC - Ecuador.')

# Guardar la base
saveRDS(base, "./2024/Trimestrales/2_abr_jun/tratadas/personas/base_acum_balanceo.rds")

4.- Recorte de los factores de expansión extremos de la ENEMDU Trimestral

Debido a los ajustes por cobertura y calibración la variabilidad de los factores de expansión se ha visto incrementada. Potter (1990) señala que la variación extrema en los factores de expansión puede resultar en varianzas muestrales excesivamente grandes.

Analisis estadístico descriptivo

summary(base_fexp$fexp_acum_aju)
summary(base_fexp$fexp_rec30)
summary(base_fexp$fexp_rec35)
summary(base_fexp$fexp_rec40)
summary(base_fexp$fexp_rec45)
summary(base_fexp$fexp_rec50)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37

5.- Recorte Graficos

Boxplot del factor balanceado y del recortado final (4)

par(mfrow = c(1,2))
boxplot(base_fexp$fexp_acum_aju)
title(main = "F. balanceado")
boxplot(base_fexp$fexp_rec45)
title(main = "F. recortado")

Boxplot de los factores de expansión balanceados por dominio

g1 <- base_fexp %>%
  ggplot(aes(x = dominio,
             y = fexp_acum_aju)) +
  geom_boxplot(fill = "#56B1F7", color = "#132B43") +
  labs(x = "Dominios de diseño",
       y = "Factores de expansión balanceados",
       title = " Grafico 1: Diagrama de caja de los factores de expansión balanceados 
       ENEMDU Trimestral Abril - Mayo - Junio 2024") +
  theme(plot.title = element_text(hjust = 0.5),
        axis.text = element_text(size=14))
print(g1)

ggsave(file = "boxplot_balanceados.png",
       plot = g1,
       device = "png",
       path = "./2024/Trimestrales/2_abr_jun/graficos",
       scale = 0.25, width = 1920, height = 1080, units = "mm",
       dpi = 300,
       limitsize = F)

Boxplot de los factores de expansión recortados por dominio

g2 <- base_fexp %>%
  ggplot(aes(x = dominio,
             y = fexp_rec45)) +
  geom_boxplot(fill = "#56B1F7", color = "#132B43") +
  labs(x = "Dominios de diseño",
       y = "Factores de expansión recortados",
       title = " Grafico 2: Diagrama de caja de los factores de expansión recortados 
       ENEMDU Trimestral Abril - Mayo - Junio 2024") +
  theme(plot.title = element_text(hjust = 0.5),
        axis.text = element_text(size=14))
print(g2)

ggsave(file = "boxplot_recortados.png",
       plot = g2,
       device = "png",
       path = "./2024/Trimestrales/2_abr_jun/graficos",
       scale = 0.25, width = 1920, height = 1080, units = "mm",
       dpi = 300,
       limitsize = F)

En los gráficos 1 y 2 se presentan los diagramas de caja y bigote de los factores de expansión balanceados por mes de levantamiento de información y recortados, respectivamente, a nivel de estrato de muestreo. Al realizar una comparación entre estos se aprecia que los factores de expansión balanceados son iguales a los pesos de muestreo recortados, es decir, no existieron ponderadores extremos que necesitaron ser recortados.

# Grafico
g3 <- base_fexp%>%
  mutate(gedad = ifelse(edad<15, 1, 2),
         Gedad = factor(gedad, c("1", "2"), c("< 15 años", ">= 15 años"))) %>% 
  ggplot(aes(x = fexp_acum_aju,
             y = fexp_rec45)) + 
  geom_point(aes(colour = Gedad)) +
  geom_abline(aes(intercept = 0,
                  slope = 1),
              linetype = "dashed",
              alpha=0.75) +
  #color = "#C5BEBA") +
  facet_wrap(~dominio,
             scales = "free",
             labeller = label_value) +
  labs(x = "Factor de expansión balanceado",
       y = "Factor de expansión recortado",
       title = " Grafico 3. Comparación de los factores de expansión balanceados
       vs recortados ENEMDU Trimestral Abril - Mayo - Junio 2024") +
  scale_color_manual(values = c("#113743", "#C5001A")) +
  theme(plot.title = element_text(hjust = 0.5),
        panel.background = element_rect(fill = "#E4E3DB",
                                        colour = "#E4E3DB",
                                        size = 0.5, linetype = "solid"),
        strip.background = element_rect(fill="white"))
print(g3)

ggsave(file = "recorte.png",
       plot = g3,
       device = "png",
       path = "./2024/Trimestrales/2_abr_jun/graficos",
       scale = 0.25, width = 1920, height = 1080, units = "mm",
       dpi = 300,
       limitsize = F)

En el Gráfico 3 se puede evidenciar que no se presentan factores de expansión recortados en los diferentes dominios, por cuanto los pesos de muestreo están sobre la línea de 45 grados, esto significa que los ponderadores recortados son iguales a los balanceados.

6.- Calibración Previa

Creación de variables id_calib

base <- base_fexp %>%
  mutate(gedad = ifelse(edad<15, 1, 2),
         id_calib= paste0(dom7, "_", area, "_", sexo, "_", gedad))
print(table(base$id_calib, useNA = "ifany"))
## 
## 01_1_1_1 01_1_1_2 01_1_2_1 01_1_2_2 02_1_1_1 02_1_1_2 02_1_2_1 02_1_2_2 
##      730     3240      748     3677      991     3390      935     3806 
## 03_1_1_1 03_1_1_2 03_1_2_1 03_1_2_2 04_1_1_1 04_1_1_2 04_1_2_1 04_1_2_2 
##      559     2257      458     2656      758     2678      608     2923 
## 05_1_1_1 05_1_1_2 05_1_2_1 05_1_2_2 06_1_1_1 06_1_1_2 06_1_2_1 06_1_2_2 
##      492     1868      440     2150     3103     9890     2937    11379 
## 07_2_1_1 07_2_1_2 07_2_2_1 07_2_2_2 
##     2823     8728     2584     8900
n_distinct(base$id_calib)
## [1] 28

Creación del diseño de muestreo

est_pob <- base %>%
  as_survey_design(ids = id_upm,
                   strat = estrato, 
                   weights = fexp_acum_aju,
                   nest = T)
options(survey.lonely.psu="adjust")
sum(weights(est_pob))
## [1] 10821585

Coeficientes de variación

est_pob_v_28 %>%
  kbl(caption = "Tabla 2: Coeficientes de variación") %>%
  kable_paper("hover", full_width = F)
Tabla 2: Coeficientes de variación
Dominios Area Sexo G_edad id_calib n var1 var1_cv control
Quito Urbana Hombre < 15 años 01_1_1_1 730 107455.82 0.0438818 0
Quito Urbana Hombre > 15 años 01_1_1_2 3240 490736.65 0.0195160 0
Quito Urbana Mujer < 15 años 01_1_2_1 748 109350.23 0.0416969 0
Quito Urbana Mujer > 15 años 01_1_2_2 3677 553529.37 0.0162805 0
Guayaquil Urbana Hombre < 15 años 02_1_1_1 991 197878.32 0.0384821 0
Guayaquil Urbana Hombre > 15 años 02_1_1_2 3390 693440.40 0.0190516 0
Guayaquil Urbana Mujer < 15 años 02_1_2_1 935 187005.20 0.0401045 0
Guayaquil Urbana Mujer > 15 años 02_1_2_2 3806 781811.44 0.0181740 0
Cuenca Urbana Hombre < 15 años 03_1_1_1 559 22626.63 0.0530650 0
Cuenca Urbana Hombre > 15 años 03_1_1_2 2257 90565.15 0.0207494 0
Cuenca Urbana Mujer < 15 años 03_1_2_1 458 18291.51 0.0575654 0
Cuenca Urbana Mujer > 15 años 03_1_2_2 2656 106883.70 0.0203725 0
Machala Urbana Hombre < 15 años 04_1_1_1 758 20123.83 0.0438333 0
Machala Urbana Hombre > 15 años 04_1_1_2 2678 71460.78 0.0204281 0
Machala Urbana Mujer < 15 años 04_1_2_1 608 16334.35 0.0480484 0
Machala Urbana Mujer > 15 años 04_1_2_2 2923 77832.51 0.0192156 0
Ambato Urbana Hombre < 15 años 05_1_1_1 492 12007.70 0.0508751 0
Ambato Urbana Hombre > 15 años 05_1_1_2 1868 45338.80 0.0200146 0
Ambato Urbana Mujer < 15 años 05_1_2_1 440 10819.12 0.0516418 0
Ambato Urbana Mujer > 15 años 05_1_2_2 2150 52300.40 0.0202921 0
Resto urbano Urbana Hombre < 15 años 06_1_1_1 3103 471653.64 0.0315689 0
Resto urbano Urbana Hombre > 15 años 06_1_1_2 9890 1568908.31 0.0153704 0
Resto urbano Urbana Mujer < 15 años 06_1_2_1 2937 426523.56 0.0310384 0
Resto urbano Urbana Mujer > 15 años 06_1_2_2 11379 1778644.62 0.0138250 0
Rural Rural Hombre < 15 años 07_2_1_1 2823 324684.93 0.0325356 0
Rural Rural Hombre > 15 años 07_2_1_2 8728 1120997.77 0.0159552 0
Rural Rural Mujer < 15 años 07_2_2_1 2584 299731.37 0.0379194 0
Rural Rural Mujer > 15 años 07_2_2_2 8900 1164648.52 0.0173244 0

7.- Calibración de los factores de expansión de la ENEMDU Trimestral

La calibración de los factores de expansión (Deville J.C., Särndal C.E. y Sautory O., 1993) es un ajuste que se realiza a los ponderadores con el propósito de que las estimaciones de algunas variables de control reproduzcan con exactitud los totales poblacionales de dichas variables.

Cabe mencionar que, en este proceso de construcción de factores de expansión para la ENEMDU, se calibra los pesos de muestreo recortados, por tanto, los gponderadores calibrados son calculados con la siguiente expresión:

\[w_{k_c}= w_{k_r}*g_{k} \]Donde: \(w_{k_c}\) son los factores de expansión calibrados, mientras que \(w_{k_r}\) son los pesos de muestreo recortados y \(g_{k}\) los pesos de calibración.

Cabe señalar que la calibración de los factores de expansión se realizó a nivel de UPM, es decir, todos los individuos de una UPM presentaban un mismo ponderador, independientemente de sus características demográficas como edad y sexo.

Comprobacion que el fexp ajustado/recortado sea unico por hogar

compro_rec = base %>%
  group_by(id_upm, vivienda, hogar, mes) %>%
  summarise(f_rec = n_distinct(fexp_acum_aju))
table(compro_rec$f_rec)
## 
##     1 
## 26327

Poblaciones objetivo para la calibracion

  pob <- readRDS("./2024/Trimestrales/2_abr_jun/proyecciones/proyecciones.rds")
pob = pob %>%
  select(dom7, area, p02, gedad, ykn)
sum(pob$ykn)
## [1] 18579256
pop <- pob %>% 
  mutate(id_calib = paste0(dom7, "_", area, "_", p02, "_", gedad)) %>%
  select(id_calib, t = ykn)

Comprobaciones: ver tp y t

vis <- tp %>% 
  full_join(pop, by="id_calib") %>% 
  mutate(dif = d-t) %>% 
  arrange(id_calib)%>%
  mutate(cotas = t/d)
vis %>%
  kbl(caption = "Tabla 3: Comprobaciones: ver tp y t") %>%
  kable_paper("hover", full_width = F)
Tabla 3: Comprobaciones: ver tp y t
Dominios Area Sexo G_edad id_calib d t dif cotas
Quito Urbana Hombre < 15 años 01_1_1_1 107455.82 212106 -104650.18 1.973890
Quito Urbana Hombre > 15 años 01_1_1_2 490736.65 789389 -298652.35 1.608580
Quito Urbana Mujer < 15 años 01_1_2_1 109350.23 235891 -126540.77 2.157206
Quito Urbana Mujer > 15 años 01_1_2_2 553529.37 853357 -299827.63 1.541665
Guayaquil Urbana Hombre < 15 años 02_1_1_1 197878.32 328060 -130181.68 1.657887
Guayaquil Urbana Hombre > 15 años 02_1_1_2 693440.40 1028145 -334704.60 1.482673
Guayaquil Urbana Mujer < 15 años 02_1_2_1 187005.20 348415 -161409.80 1.863130
Guayaquil Urbana Mujer > 15 años 02_1_2_2 781811.44 1093837 -312025.56 1.399106
Cuenca Urbana Hombre < 15 años 03_1_1_1 22626.63 47966 -25339.37 2.119891
Cuenca Urbana Hombre > 15 años 03_1_1_2 90565.15 152398 -61832.85 1.682744
Cuenca Urbana Mujer < 15 años 03_1_2_1 18291.51 55338 -37046.49 3.025338
Cuenca Urbana Mujer > 15 años 03_1_2_2 106883.70 175684 -68800.30 1.643693
Machala Urbana Hombre < 15 años 04_1_1_1 20123.83 34342 -14218.17 1.706534
Machala Urbana Hombre > 15 años 04_1_1_2 71460.78 108851 -37390.22 1.523227
Machala Urbana Mujer < 15 años 04_1_2_1 16334.35 35150 -18815.65 2.151907
Machala Urbana Mujer > 15 años 04_1_2_2 77832.51 111328 -33495.49 1.430353
Ambato Urbana Hombre < 15 años 05_1_1_1 12007.70 22432 -10424.30 1.868135
Ambato Urbana Hombre > 15 años 05_1_1_2 45338.80 75100 -29761.20 1.656418
Ambato Urbana Mujer < 15 años 05_1_2_1 10819.12 25026 -14206.88 2.313128
Ambato Urbana Mujer > 15 años 05_1_2_2 52300.40 83796 -31495.60 1.602206
Resto urbano Urbana Hombre < 15 años 06_1_1_1 471653.64 1028696 -557042.36 2.181041
Resto urbano Urbana Hombre > 15 años 06_1_1_2 1568908.31 2296830 -727921.69 1.463967
Resto urbano Urbana Mujer < 15 años 06_1_2_1 426523.56 1090139 -663615.44 2.555871
Resto urbano Urbana Mujer > 15 años 06_1_2_2 1778644.62 2433926 -655281.38 1.368416
Rural Rural Hombre < 15 años 07_2_1_1 324684.93 961720 -637035.07 2.962010
Rural Rural Hombre > 15 años 07_2_1_2 1120997.77 2007402 -886404.23 1.790728
Rural Rural Mujer < 15 años 07_2_2_1 299731.37 949855 -650123.63 3.169021
Rural Rural Mujer > 15 años 07_2_2_2 1164648.52 1994077 -829428.48 1.712171

Pesos de calibracion - distancias

Análisis estadístico: Hogar integrado

# HOGAR
calibracion_hog_cepal <- cal_hog_cepal  %>% 
  mutate(g_hog_c = calib(Xs = as.matrix(.[,8:dim(.)[2]]),
                         d = fexp_acum_aju,
                         total = vis$t,
                         method ="raking"),
         fexp_cal_hog_c_trim = fexp_acum_aju*g_hog_c) %>% 
  select(id_upm, vivienda, hogar, persona, mes, g_hog_c, fexp_cal_hog_c_trim)

summary(calibracion_hog_cepal$g_hog_c)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.5557  1.2486  1.5437  1.7761  2.1303  8.3985
summary(calibracion_hog_cepal$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.066   61.034  142.318  216.774  267.848 3649.539

Análisis estadístico: UPM

#UPM
calibracion_upm <- cal_upm  %>%
  mutate(g_upm = calib(Xs = as.matrix(.[,6:dim(.)[2]]),
                       d = fexp_acum_aju,
                       total = vis$t,
                       method ="raking"),
         fexp_cal_upm_trim = fexp_acum_aju*g_upm) %>% 
  select(id_upm, mes, g_upm, fexp_cal_upm_trim)

summary(calibracion_upm$g_upm)
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##   0.04013   0.81870   1.20284   1.71099   1.79551 127.60384
summary(calibracion_upm$fexp_cal_upm_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    3.103   42.264  103.280  190.605  223.416 7496.631

Análisis estadístico: Persona

# Persona

calibracion_per <- cal_per  %>%
  mutate(g_per = calib(Xs = as.matrix(.[,7:dim(.)[2]]),
                       d = fexp_acum_aju,
                       total = vis$t,
                       method ="raking"),
         fexp_cal_per = fexp_acum_aju*g_per) %>%
  select(id_upm, vivienda, hogar, persona, mes,g_per, fexp_cal_per)
summary(calibracion_per$g_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   1.368   1.464   1.609   1.744   1.791   3.169
summary(calibracion_per$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   17.40   70.15  142.94  216.77  269.64 2853.29

Verificacion de las poblaciones

comp = base_fexp %>%
  group_by(id_calib) %>%
  summarise(pob_comp_hog_c = sum(fexp_cal_hog_c_trim),
            pob_comp_upm = sum(fexp_cal_upm_trim),
            pob_comp_per = sum(fexp_cal_per))

comp = comp %>% 
  full_join(select(vis, id_calib, t), 
            by = "id_calib") %>%
  mutate(dif_comp_hog_c = pob_comp_hog_c - t,
         dif_comp_upm = pob_comp_upm - t,
         dif_comp_per = pob_comp_per - t)
comp %>%
  kbl(caption = "Tabla 4: vis") %>%
  kable_paper("hover", full_width = F)
Tabla 4: vis
Dominios Area Sexo G_edad id_calib pob_comp_hog_c pob_comp_upm pob_comp_per t dif_comp_hog_c dif_comp_upm dif_comp_per
Quito Urbana Hombre < 15 años 01_1_1_1 212106 212106 212106 212106 0.0000000 0.0e+00 0.0e+00
Quito Urbana Hombre > 15 años 01_1_1_2 789389 789389 789389 789389 0.0000000 0.0e+00 0.0e+00
Quito Urbana Mujer < 15 años 01_1_2_1 235891 235891 235891 235891 0.0000000 0.0e+00 0.0e+00
Quito Urbana Mujer > 15 años 01_1_2_2 853357 853357 853357 853357 0.0000000 0.0e+00 0.0e+00
Guayaquil Urbana Hombre < 15 años 02_1_1_1 328060 328060 328060 328060 0.0000000 0.0e+00 0.0e+00
Guayaquil Urbana Hombre > 15 años 02_1_1_2 1028145 1028145 1028145 1028145 0.0000000 0.0e+00 0.0e+00
Guayaquil Urbana Mujer < 15 años 02_1_2_1 348415 348415 348415 348415 0.0000000 0.0e+00 0.0e+00
Guayaquil Urbana Mujer > 15 años 02_1_2_2 1093837 1093837 1093837 1093837 0.0000000 0.0e+00 0.0e+00
Cuenca Urbana Hombre < 15 años 03_1_1_1 47966 47966 47966 47966 0.0000029 0.0e+00 0.0e+00
Cuenca Urbana Hombre > 15 años 03_1_1_2 152398 152398 152398 152398 0.0000074 0.0e+00 0.0e+00
Cuenca Urbana Mujer < 15 años 03_1_2_1 55338 55338 55338 55338 0.0000138 0.0e+00 0.0e+00
Cuenca Urbana Mujer > 15 años 03_1_2_2 175684 175684 175684 175684 0.0000108 0.0e+00 0.0e+00
Machala Urbana Hombre < 15 años 04_1_1_1 34342 34342 34342 34342 0.0000000 0.0e+00 0.0e+00
Machala Urbana Hombre > 15 años 04_1_1_2 108851 108851 108851 108851 0.0000000 0.0e+00 0.0e+00
Machala Urbana Mujer < 15 años 04_1_2_1 35150 35150 35150 35150 0.0000000 0.0e+00 0.0e+00
Machala Urbana Mujer > 15 años 04_1_2_2 111328 111328 111328 111328 0.0000000 0.0e+00 0.0e+00
Ambato Urbana Hombre < 15 años 05_1_1_1 22432 22432 22432 22432 0.0000000 0.0e+00 0.0e+00
Ambato Urbana Hombre > 15 años 05_1_1_2 75100 75100 75100 75100 0.0000000 0.0e+00 0.0e+00
Ambato Urbana Mujer < 15 años 05_1_2_1 25026 25026 25026 25026 0.0000000 0.0e+00 0.0e+00
Ambato Urbana Mujer > 15 años 05_1_2_2 83796 83796 83796 83796 0.0000000 0.0e+00 0.0e+00
Resto urbano Urbana Hombre < 15 años 06_1_1_1 1028696 1028696 1028696 1028696 0.0000000 0.0e+00 0.0e+00
Resto urbano Urbana Hombre > 15 años 06_1_1_2 2296830 2296830 2296830 2296830 0.0000000 0.0e+00 0.0e+00
Resto urbano Urbana Mujer < 15 años 06_1_2_1 1090139 1090139 1090139 1090139 0.0000000 0.0e+00 0.0e+00
Resto urbano Urbana Mujer > 15 años 06_1_2_2 2433926 2433926 2433926 2433926 0.0000000 0.0e+00 0.0e+00
Rural Rural Hombre < 15 años 07_2_1_1 961720 961720 961720 961720 0.0038961 2.7e-06 0.0e+00
Rural Rural Hombre > 15 años 07_2_1_2 2007402 2007402 2007402 2007402 0.0048830 1.5e-06 0.0e+00
Rural Rural Mujer < 15 años 07_2_2_1 949855 949855 949855 949855 0.0095258 1.7e-06 1.7e-06
Rural Rural Mujer > 15 años 07_2_2_2 1994077 1994077 1994077 1994077 0.0066992 1.5e-06 0.0e+00

Diferencia máxima: hogar integrado

max(comp$dif_comp_hog_c)
## [1] 0.009525827

Diferencia máxima: UPM

max(comp$dif_comp_upm)
## [1] 2.673594e-06

Diferencia máxima: Persona

max(comp$dif_comp_per)
## [1] 1.719221e-06

Analisis estadístico descriptivo

Sumatoria poblacion objetivo

sum(vis$t)
## [1] 18579256

Descriptivo Factor de expansión teorico

summary(base_fexp$fexp_acum_teo)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.62   39.29   81.55  124.55  160.40 1116.37
sum(base_fexp$fexp_acum_teo)
## [1] 10675322

Descriptivo Factor de expansión ajustado

summary(base_fexp$fexp_acum_aju)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   12.71   39.98   82.58  126.26  163.52 1116.37
sum(base_fexp$fexp_acum_aju)
## [1] 10821585

Descriptivo Factor de expansión calibrado (upm)

summary(base_fexp$fexp_cal_upm_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    3.103   46.475  113.057  216.774  242.954 7496.631
sum(base_fexp$fexp_cal_upm_trim)
## [1] 18579256

Descriptivo Factor de expansión calibrado (hogar)

summary(base_fexp$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.066   61.034  142.318  216.774  267.848 3649.539
sum(base_fexp$fexp_cal_hog_c_trim)
## [1] 18579256

Descriptivo Factor de expansión calibrado (persona)

summary(base_fexp$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   17.40   70.15  142.94  216.77  269.64 2853.29
sum(base_fexp$fexp_cal_per)
## [1] 18579256

Gráfico

g4 <- base_fexp%>%
  mutate(Gedad = factor(gedad, c("1", "2"), c("< 15 Años", ">= 15 Años"))) %>% 
  # filter(provin %in% c("03", "12", "17", "18", "19", "23")) %>%
  # group_by(provin) %>%
  # filter(fexp_final_enlis != max(fexp_final_enlis)) %>%
  ggplot(aes(x = fexp_acum_aju,
             y = fexp_cal_upm_trim)) + 
  geom_point(aes(colour = Gedad)) +
  geom_abline(aes(intercept = 0,
                  slope = 1),
              linetype = "dashed",
              alpha=0.75) +
  #color = "#C5BEBA") +
  facet_wrap(~dominio,
             scales = "free",
             labeller = label_value) +
  labs(x = "Factor de expansión recortado",
       y = "Factor de expansión calibrado",
       title = "Comparación de los factores de expansión recortados 
         vs calibrados ENEMDU Trimestral Abril - Mayo - Junio 2024") +
  scale_color_manual(values = c("#113743", "#C5001A")) +
  theme(plot.title = element_text(hjust = 0.5),
        panel.background = element_rect(fill = "#E4E3DB",
                                        colour = "#E4E3DB",
                                        size = 0.5, linetype = "solid"),
        strip.background = element_rect(fill="white"))

print(g4)

ggsave(file = "calibracion.png",
       plot = g4,
       device = "png",
       path = "./2024/Trimestrales/2_abr_jun/graficos",
       scale = 0.25, width = 1920, height = 1080, units = "mm",
       dpi = 300,
       limitsize = F)

En la mayoría de dominios, los factores de expansión calibrados son más grandes que los ponderadores recortados, debido a la condición de reproducir con exactitud los totales poblacionales por sexo y grupo de edad , en las diferentes celdas o post estratos de calibración.

8.- Validación de la calibración de los factores de expansión

Medidas de calidad Silva A.G.

Silva (2004) propone 6 medidas para evaluar la calidad de la calibración de los factores de expansión, las cuales se detallan a continuación:

Error relativo promedio sobre las variables auxiliares (M1)

\[ M1= \frac{1}{p}\sum_{j=1}^{p}\frac{\left | \hat{t}_{xc} -t_{x}\right |}{t_{x}} \]

M1 <- vis %>%
  full_join(base, by=c("dom7", "id_calib")) %>%
  group_by(dom7, id_calib) %>%
  summarise(T_xjC_upm = sum(fexp_cal_upm_trim),
            T_xjC_hog = sum(fexp_cal_hog_c_trim),
            T_xjC_per = sum(fexp_cal_per),
            T_xj = mean(t)) %>%
  group_by(dom7) %>%
  summarise(p = n(),
            er_upm = sum(abs(T_xjC_upm - T_xj)/T_xj)/p,
            er_hog = sum(abs(T_xjC_hog - T_xj)/T_xj)/p,
            er_per = sum(abs(T_xjC_per - T_xj)/T_xj)/p)
M1 %>%
  kbl(caption = "Medida 1") %>%
  kable_paper("hover", full_width = F)
Medida 1
Dominios p er_upm er_hog er_per
Quito 4 0 0 0
Guayaquil 4 0 0 0
Cuenca 4 0 0 0
Machala 4 0 0 0
Ambato 4 0 0 0
Resto urbano 4 0 0 0
Rural 4 0 0 0

Coeficiente de variación HT relativo promedio (M2)

\[ M2= \frac{1}{p}\sum_{j=1}^{p}\frac{(Var(\hat{t}_{x\pi }))^{1/2}}{t_{x}}. \]

M2_upm <- enemdu_upm %>%
  group_by(id_calib) %>%
  summarise(var1 = survey_total(vartype="cv", na.rm=T)) %>%
  mutate(dom7 = substr(id_calib, 1, 2),
         dom7 = ifelse(dom7 == "00", "12", dom7)) %>%
  group_by(dom7) %>%
  summarise(n = n(),
            cv_upm = sum(var1_cv)/n)

M2_hog <- enemdu_hog %>%
  group_by(id_calib) %>%
  summarise(var1 = survey_total(vartype="cv", na.rm=T)) %>%
  mutate(dom7 = substr(id_calib, 1, 2),
         dom7 = ifelse(dom7 == "00", "12", dom7)) %>%
  group_by(dom7) %>%
  summarise(n = n(),
            cv_hog = sum(var1_cv)/n) %>%
  select(-n)

M2_per <- enemdu_per %>%
  group_by(id_calib) %>%
  summarise(var1 = survey_total(vartype="cv", na.rm=T)) %>%
  mutate(dom7 = substr(id_calib, 1, 2),
         dom7 = ifelse(dom7 == "00", "12", dom7)) %>%
  group_by(dom7) %>%
  summarise(n = n(),
            cv_per = sum(var1_cv)/n) %>%
  select(-n)

M2 = M2_upm %>%
  left_join(M2_hog, by = "dom7") %>%
  left_join(M2_per, by= "dom7")
M2 %>%
  kbl(caption = "Medida 2") %>%
  kable_paper("hover", full_width = F)
Medida 2
Dominios n cv_upm cv_hog cv_per
Quito 4 0.0514661 0.0311979 0.0303438
Guayaquil 4 0.0474685 0.0297245 0.0289531
Cuenca 4 0.0983363 0.0414013 0.0379381
Machala 4 0.0653902 0.0347246 0.0328813
Ambato 4 0.0695539 0.0368526 0.0357059
Resto urbano 4 0.0731411 0.0260439 0.0229507
Rural 4 0.1065350 0.0302087 0.0259337

Proporción de pesos extremos (límite inferior) (M3)

\[ M3= \frac{1}{n}\sum_{k\epsilon S}^{}I(g_{k}<L). \]

M3 <- base %>%
  left_join(cotas, by = "dom7") %>%
  group_by(dom7) %>%
  summarise(L = 1,
            n = n(),
            M3_upm = sum(g_upm < L)/n*100,
            M3_hog = sum(g_hog_c < L)/n*100,
            M3_per = sum(g_per < L)/n*100)
M3 %>%
  kbl(caption = "Medida 3") %>%
  kable_paper("hover", full_width = F)
Medida 3
Dominios L n M3_upm M3_hog M3_per
Quito 1 8395 22.06075 0.000000 0
Guayaquil 1 9122 18.29643 0.000000 0
Cuenca 1 5930 39.10624 0.000000 0
Machala 1 6967 34.00316 4.621788 0
Ambato 1 4950 27.71717 0.000000 0
Resto urbano 1 27309 54.61569 26.375920 0
Rural 1 23035 17.99870 8.782288 0

Proporción de pesos extremos (límite superior) (M4)

\[ M4= \frac{1}{n}\sum_{k\epsilon S}^{}I(g_{k}>U). \]

M4 <- base %>%
  left_join(cotas, by = "dom7") %>%
  group_by(dom7) %>%
  summarise(n = n(),
            U = mean(U),
            U3 = mean(U3),
            M4_upm_U = sum(g_upm > U)/n*100,
            M4_upm_U3 = sum(g_upm > U3)/n*100,
            M4_hog_U = sum(g_hog_c > U)/n*100,
            M4_hog_U3 = sum(g_hog_c > U3)/n*100,
            M4_per_U = sum(g_per > U)/n*100,
            M4_per_U3 = sum(g_per > U3)/n*100)
M4 %>%
  kbl(caption = "Medida 4") %>%
  kable_paper("hover", full_width = F)
Medida 4
Dominios n U U3 M4_upm_U M4_upm_U3 M4_hog_U M4_hog_U3 M4_per_U M4_per_U3
Quito 8395 2.157206 3 21.50089 6.444312 11.983323 0.1310304 8.910065 0.00000
Guayaquil 9122 1.863130 3 21.06994 4.527516 14.075861 0.0000000 0.000000 0.00000
Cuenca 5930 3.025338 3 11.87184 13.153457 6.559865 6.5598651 7.723440 7.72344
Machala 6967 2.151907 3 20.74063 8.152720 13.391704 0.6171953 0.000000 0.00000
Ambato 4950 2.313128 3 19.67677 11.292929 7.636364 1.1313131 0.000000 0.00000
Resto urbano 27309 2.555871 3 18.53235 14.896188 14.954777 7.4883738 0.000000 0.00000
Rural 23035 3.169021 3 12.31604 14.013458 18.450184 21.3761667 11.217712 11.21771

Coeficiente de variación de los \(g_{k}\) (M5)

\[ M5= \frac{\sigma (g)}{\bar{g}}. \]

M5 <- base %>%
  group_by(dom7) %>%
  summarise(n = n(),
            cv_g_upm = sd(g_upm)/mean(g_upm),
            cv_g_hog = sd(g_hog_c)/mean(g_hog_c),
            cv_g_per = sd(g_per)/mean(g_per))
M5 %>%
  kbl(caption = "Medida 5") %>%
  kable_paper("hover", full_width = F)
Medida 5
Dominios n cv_g_upm cv_g_hog cv_g_per
Quito 8395 0.6026996 0.2268250 0.1170543
Guayaquil 9122 0.4771661 0.1964536 0.0952006
Cuenca 5930 1.1575118 0.4068978 0.2079597
Machala 6967 0.7029810 0.2802227 0.1290612
Ambato 4950 0.6474730 0.2308320 0.1181865
Resto urbano 27309 1.7080127 0.5188619 0.2503811
Rural 23035 2.9481198 0.5349664 0.2713048

Distancia entre los pesos de calibración y los pesos originales (M6)

\[ M6= \frac{1}{n}\sum_{k\varepsilon S}^{}\frac{(w_{_k{c}}-w_{_k{r}})^{2}}{w_{_k{r}}}=\frac{1}{n}\sum_{k\varepsilon S}^{}w_{_k{r}}(g_{k}-1)^{2}. \]

M6 <- base %>%
  group_by(dom7) %>%
  summarise(n = n(),
            dist_g_upm = sum((fexp_cal_upm_trim - fexp_acum_aju)^2/fexp_acum_aju)/n,
            dist_g_hog = sum((fexp_cal_hog_c_trim - fexp_acum_aju)^2/fexp_acum_aju)/n,
            dist_g_per = sum((fexp_cal_per - fexp_acum_aju)^2/fexp_acum_aju)/n)
M6 %>%
  kbl(caption = "Medida 6") %>%
  kable_paper("hover", full_width = F)
Medida 6
Dominios n dist_g_upm dist_g_hog dist_g_per
Quito 8395 207.28328 86.01114 70.57910
Guayaquil 9122 157.75538 69.49736 56.02351
Cuenca 5930 191.90457 48.08244 32.02552
Machala 6967 39.75280 13.34738 9.42988
Ambato 4950 41.94973 16.19068 13.37531
Resto urbano 27309 1226.30316 166.45582 83.10585
Rural 23035 3585.49903 287.97419 171.54765