Dirección de Infraestructura Estadística y muestreo DINEM

ENEMDU Octubre - Noviembre - Diciembre 2024

1.- Preparación

Bases de viviendas

kable(viviendas)
Octubre Noviembre Diciembre
UPM 1288 1288 1288
Vivienda 8767 8731 8677
Hogar 8792 8773 8726 
# kable(upm_ac)
# kable(fc_ac)
# kable(ef_ac)

Bases de personas

‘r names(v1)’

kable(personas)
Octubre Noviembre Diciembre
UPM 1288 1288 1288
Vivienda 8767 8731 8677
Hogar 8792 8773 8726
Personas 28028 28264 27610 
# Guardar las bases tratadas de personas
saveRDS(p1, "./2024/Trimestrales/4_oct_dic/tratadas/personas/p1.rds")
saveRDS(p2, "./2024/Trimestrales/4_oct_dic/tratadas/personas/p2.rds")
saveRDS(p3, "./2024/Trimestrales/4_oct_dic/tratadas/personas/p3.rds")

2.- Preparación Factores Mensuales

Factores de expansión

  • Periodo 1 Octubre
p1_fexp = readRDS(file = "./2024/Factores mensuales/10_Octubre/FEXP_ENEMDU_T_202410.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 Noviembre
p2_fexp = readRDS(file = "./2024/Factores mensuales/11_Noviembre/FEXP_ENEMDU_T_202411.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 Diciembre
p3_fexp = readRDS(file = "./2024/Factores mensuales/12_Diciembre/FEXP_ENEMDU_T_202412.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] 83902    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: Octubre - Noviembre - Diciembre 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: Octubre - Noviembre - Diciembre 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 : Octubre - Noviembre - Diciembre") +
#   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: Octubre - Noviembre - Diciembre") +
 #  # 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  120.16  254.72  379.66  483.43 3528.57
# 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. 
##   35.62  122.05  256.89  388.92  491.62 4615.41
# 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/4_oct_dic/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 
##  8078  8963  5856  6813  4843 26818 22531
table(base$dominio, useNA = "ifany")
## 
##    01    02    03    04    05    06    07    08    09    10    11    12 
##  8078  8963  5856  6813  4843 12014 10267  4122 10536  5898  5697   815

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 10 2683 0.3321367
01 11 2805 0.3472394
01 12 2590 0.3206239
02 10 3011 0.3359366
02 11 2994 0.3340399
02 12 2958 0.3300234
03 10 1943 0.3317964
03 11 2002 0.3418716
03 12 1911 0.3263320
04 10 2224 0.3264348
04 11 2291 0.3362689
04 12 2298 0.3372963
05 10 1667 0.3442081
05 11 1617 0.3338840
05 12 1559 0.3219079
06 10 9067 0.3380938
06 11 8975 0.3346633
06 12 8776 0.3272429
07 10 7433 0.3299010
07 11 7580 0.3364254
07 12 7518 0.3336736

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.3206  0.3299  0.3340  0.3334  0.3364  0.3472

Factor de expansión teórico acumulado

summary(base$fexp_acum_teo)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   39.92   84.60  126.58  160.31 1192.99
# 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. 
##   11.89   40.79   85.88  129.65  164.09 1510.36
# 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/4_oct_dic/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. 
##   11.89   40.79   85.88  129.65  164.09 1510.36 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36 
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36

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 Octubre - Noviembre - Diciembre 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/4_oct_dic/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 Octubre - Noviembre - Diciembre 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/4_oct_dic/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 Octubre - Noviembre - Diciembre 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/4_oct_dic/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 
##      725     3100      685     3568      980     3342      899     3742 
## 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 
##      519     2209      508     2620      701     2618      674     2820 
## 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 
##      412     1795      401     2235     2915     9810     2723    11370 
## 07_2_1_1 07_2_1_2 07_2_2_1 07_2_2_2 
##     2602     8564     2410     8955
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] 10877664

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 725 106142.184 0.0454234 0
Quito Urbana Hombre > 15 años 01_1_1_2 3100 470555.624 0.0207456 0
Quito Urbana Mujer < 15 años 01_1_2_1 685 100563.914 0.0501047 0
Quito Urbana Mujer > 15 años 01_1_2_2 3568 536247.575 0.0160736 0
Guayaquil Urbana Hombre < 15 años 02_1_1_1 980 195936.883 0.0406042 0
Guayaquil Urbana Hombre > 15 años 02_1_1_2 3342 690550.523 0.0193989 0
Guayaquil Urbana Mujer < 15 años 02_1_2_1 899 179238.362 0.0412620 0
Guayaquil Urbana Mujer > 15 años 02_1_2_2 3742 768127.328 0.0172959 0
Cuenca Urbana Hombre < 15 años 03_1_1_1 519 21064.383 0.0569274 0
Cuenca Urbana Hombre > 15 años 03_1_1_2 2209 89662.767 0.0233479 0
Cuenca Urbana Mujer < 15 años 03_1_2_1 508 21047.595 0.0552669 0
Cuenca Urbana Mujer > 15 años 03_1_2_2 2620 106494.382 0.0203274 0
Machala Urbana Hombre < 15 años 04_1_1_1 701 18800.078 0.0449823 0
Machala Urbana Hombre > 15 años 04_1_1_2 2618 70265.619 0.0202244 0
Machala Urbana Mujer < 15 años 04_1_2_1 674 18152.513 0.0482167 0
Machala Urbana Mujer > 15 años 04_1_2_2 2820 75336.614 0.0181820 0
Ambato Urbana Hombre < 15 años 05_1_1_1 412 9953.649 0.0525184 0
Ambato Urbana Hombre > 15 años 05_1_1_2 1795 44256.983 0.0248090 0
Ambato Urbana Mujer < 15 años 05_1_2_1 401 9810.348 0.0605221 0
Ambato Urbana Mujer > 15 años 05_1_2_2 2235 54825.466 0.0205134 0
Resto urbano Urbana Hombre < 15 años 06_1_1_1 2915 464707.553 0.0406860 0
Resto urbano Urbana Hombre > 15 años 06_1_1_2 9810 1615980.185 0.0179936 0
Resto urbano Urbana Mujer < 15 años 06_1_2_1 2723 434853.567 0.0423550 0
Resto urbano Urbana Mujer > 15 años 06_1_2_2 11370 1857732.433 0.0172292 0
Rural Rural Hombre < 15 años 07_2_1_1 2602 306367.984 0.0335415 0
Rural Rural Hombre > 15 años 07_2_1_2 8564 1120096.042 0.0168295 0
Rural Rural Mujer < 15 años 07_2_2_1 2410 284184.967 0.0381901 0
Rural Rural Mujer > 15 años 07_2_2_2 8955 1206708.140 0.0168800 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 
## 26291

Poblaciones objetivo para la calibracion

  pob <- readRDS("./2024/Trimestrales/4_oct_dic/proyecciones/proyecciones.rds")
pob = pob %>%
  select(dom7, area, p02, gedad, ykn)
sum(pob$ykn)
## [1] 18706022
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 106142.184 213553 -107410.82 2.011952
Quito Urbana Hombre > 15 años 01_1_1_2 470555.624 794775 -324219.38 1.689014
Quito Urbana Mujer < 15 años 01_1_2_1 100563.914 237501 -136937.09 2.361692
Quito Urbana Mujer > 15 años 01_1_2_2 536247.575 859180 -322932.43 1.602208
Guayaquil Urbana Hombre < 15 años 02_1_1_1 195936.883 330298 -134361.12 1.685737
Guayaquil Urbana Hombre > 15 años 02_1_1_2 690550.523 1035161 -344610.48 1.499037
Guayaquil Urbana Mujer < 15 años 02_1_2_1 179238.362 350792 -171553.64 1.957126
Guayaquil Urbana Mujer > 15 años 02_1_2_2 768127.328 1101301 -333173.67 1.433748
Cuenca Urbana Hombre < 15 años 03_1_1_1 21064.383 48293 -27228.62 2.292638
Cuenca Urbana Hombre > 15 años 03_1_1_2 89662.767 153437 -63774.23 1.711268
Cuenca Urbana Mujer < 15 años 03_1_2_1 21047.595 55716 -34668.40 2.647143
Cuenca Urbana Mujer > 15 años 03_1_2_2 106494.382 176883 -70388.62 1.660961
Machala Urbana Hombre < 15 años 04_1_1_1 18800.078 34577 -15776.92 1.839195
Machala Urbana Hombre > 15 años 04_1_1_2 70265.619 109593 -39327.38 1.559696
Machala Urbana Mujer < 15 años 04_1_2_1 18152.513 35390 -17237.49 1.949592
Machala Urbana Mujer > 15 años 04_1_2_2 75336.614 112088 -36751.39 1.487829
Ambato Urbana Hombre < 15 años 05_1_1_1 9953.649 22585 -12631.35 2.269017
Ambato Urbana Hombre > 15 años 05_1_1_2 44256.983 75612 -31355.02 1.708476
Ambato Urbana Mujer < 15 años 05_1_2_1 9810.348 25196 -15385.65 2.568309
Ambato Urbana Mujer > 15 años 05_1_2_2 54825.466 84368 -29542.53 1.538847
Resto urbano Urbana Hombre < 15 años 06_1_1_1 464707.553 1035715 -571007.45 2.228746
Resto urbano Urbana Hombre > 15 años 06_1_1_2 1615980.185 2312497 -696516.82 1.431018
Resto urbano Urbana Mujer < 15 años 06_1_2_1 434853.567 1097573 -662719.43 2.524006
Resto urbano Urbana Mujer > 15 años 06_1_2_2 1857732.433 2450534 -592801.57 1.319100
Rural Rural Hombre < 15 años 07_2_1_1 306367.984 968284 -661916.02 3.160526
Rural Rural Hombre > 15 años 07_2_1_2 1120096.042 2021097 -901000.96 1.804396
Rural Rural Mujer < 15 años 07_2_2_1 284184.967 956339 -672154.03 3.365199
Rural Rural Mujer > 15 años 07_2_2_2 1206708.140 2007684 -800975.86 1.663769

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.539   1.211   1.543   1.788   2.105  14.836
summary(calibracion_hog_cepal$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    6.561   60.822  139.083  222.951  273.855 5070.579

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.0507   0.7362   1.1136   1.5668   1.7146 148.0770
summary(calibracion_upm$fexp_cal_upm_trim)
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##     4.126    40.473    96.091   183.313   208.396 27941.127

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.319   1.431   1.661   1.751   1.804   3.365
summary(calibracion_per$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   18.96   70.32  142.02  222.95  275.79 3812.16

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 213553.0 213553.0 213553 213553 0.0000000 0.0000000 0.00e+00
Quito Urbana Hombre > 15 años 01_1_1_2 794775.0 794775.0 794775 794775 0.0000000 0.0000000 0.00e+00
Quito Urbana Mujer < 15 años 01_1_2_1 237501.0 237501.0 237501 237501 0.0000000 0.0000000 0.00e+00
Quito Urbana Mujer > 15 años 01_1_2_2 859180.0 859180.0 859180 859180 0.0000000 0.0000000 0.00e+00
Guayaquil Urbana Hombre < 15 años 02_1_1_1 330298.0 330298.0 330298 330298 0.0000000 0.0000000 0.00e+00
Guayaquil Urbana Hombre > 15 años 02_1_1_2 1035161.0 1035161.0 1035161 1035161 0.0000000 0.0000000 0.00e+00
Guayaquil Urbana Mujer < 15 años 02_1_2_1 350792.0 350792.0 350792 350792 0.0000000 0.0000000 0.00e+00
Guayaquil Urbana Mujer > 15 años 02_1_2_2 1101301.0 1101301.0 1101301 1101301 0.0000000 0.0000000 0.00e+00
Cuenca Urbana Hombre < 15 años 03_1_1_1 48293.0 48293.0 48293 48293 0.0000000 0.0000000 0.00e+00
Cuenca Urbana Hombre > 15 años 03_1_1_2 153437.0 153437.0 153437 153437 0.0000000 0.0000000 0.00e+00
Cuenca Urbana Mujer < 15 años 03_1_2_1 55716.0 55716.0 55716 55716 0.0000000 0.0000000 0.00e+00
Cuenca Urbana Mujer > 15 años 03_1_2_2 176883.0 176883.0 176883 176883 0.0000000 0.0000000 0.00e+00
Machala Urbana Hombre < 15 años 04_1_1_1 34577.0 34577.0 34577 34577 0.0000000 0.0000000 0.00e+00
Machala Urbana Hombre > 15 años 04_1_1_2 109593.0 109593.0 109593 109593 0.0000000 0.0000000 0.00e+00
Machala Urbana Mujer < 15 años 04_1_2_1 35390.0 35390.0 35390 35390 0.0000000 0.0000000 0.00e+00
Machala Urbana Mujer > 15 años 04_1_2_2 112088.0 112088.0 112088 112088 0.0000000 0.0000000 0.00e+00
Ambato Urbana Hombre < 15 años 05_1_1_1 22585.0 22585.0 22585 22585 0.0000000 0.0000000 0.00e+00
Ambato Urbana Hombre > 15 años 05_1_1_2 75612.0 75612.0 75612 75612 0.0000000 0.0000000 0.00e+00
Ambato Urbana Mujer < 15 años 05_1_2_1 25196.0 25196.0 25196 25196 0.0000000 0.0000000 0.00e+00
Ambato Urbana Mujer > 15 años 05_1_2_2 84368.0 84368.0 84368 84368 0.0000000 0.0000000 0.00e+00
Resto urbano Urbana Hombre < 15 años 06_1_1_1 1035715.0 1035715.0 1035715 1035715 0.0000000 0.0000000 0.00e+00
Resto urbano Urbana Hombre > 15 años 06_1_1_2 2312497.0 2312497.0 2312497 2312497 0.0000000 0.0000000 0.00e+00
Resto urbano Urbana Mujer < 15 años 06_1_2_1 1097573.0 1097573.0 1097573 1097573 0.0000000 0.0000000 0.00e+00
Resto urbano Urbana Mujer > 15 años 06_1_2_2 2450534.0 2450534.0 2450534 2450534 0.0000000 0.0000000 -1.00e-07
Rural Rural Hombre < 15 años 07_2_1_1 968284.2 968284.9 968284 968284 0.2183705 0.8748920 1.50e-06
Rural Rural Hombre > 15 años 07_2_1_2 2021097.3 2021097.9 2021097 2021097 0.2996633 0.8798344 0.00e+00
Rural Rural Mujer < 15 años 07_2_2_1 956339.6 956339.9 956339 956339 0.5788976 0.8627700 4.07e-05
Rural Rural Mujer > 15 años 07_2_2_2 2007684.4 2007684.7 2007684 2007684 0.4123121 0.7423082 0.00e+00

Diferencia máxima: hogar integrado

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

Diferencia máxima: UPM

max(comp$dif_comp_upm)
## [1] 0.8798344

Diferencia máxima: Persona

max(comp$dif_comp_per)
## [1] 4.071707e-05

Analisis estadístico descriptivo

Sumatoria poblacion objetivo

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

Descriptivo Factor de expansión teorico

summary(base_fexp$fexp_acum_teo)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   39.92   84.60  126.58  160.31 1192.99
sum(base_fexp$fexp_acum_teo)
## [1] 10620693

Descriptivo Factor de expansión ajustado

summary(base_fexp$fexp_acum_aju)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.89   40.79   85.88  129.65  164.09 1510.36
sum(base_fexp$fexp_acum_aju)
## [1] 10877664

Descriptivo Factor de expansión calibrado (upm)

summary(base_fexp$fexp_cal_upm_trim)
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##     4.126    44.164   104.887   222.951   232.198 27941.127
sum(base_fexp$fexp_cal_upm_trim)
## [1] 18706025

Descriptivo Factor de expansión calibrado (hogar)

summary(base_fexp$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    6.561   60.822  139.083  222.951  273.855 5070.579
sum(base_fexp$fexp_cal_hog_c_trim)
## [1] 18706024

Descriptivo Factor de expansión calibrado (persona)

summary(base_fexp$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   18.96   70.32  142.02  222.95  275.79 3812.16
sum(base_fexp$fexp_cal_per)
## [1] 18706022

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 Octubre - Noviembre - Diciembre 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/4_oct_dic/graficos",
       scale = 0.25, width = 1920, height = 1080, units = "mm",
       dpi = 300,
       limitsize = F)

En la Agostorí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 0e+00 0e+00 0
Guayaquil 4 0e+00 0e+00 0
Cuenca 4 0e+00 0e+00 0
Machala 4 0e+00 0e+00 0
Ambato 4 0e+00 0e+00 0
Resto urbano 4 0e+00 0e+00 0
Rural 4 7e-07 3e-07 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.0590716 0.0346641 0.0330868
Guayaquil 4 0.0491877 0.0307629 0.0296403
Cuenca 4 0.0844471 0.0410163 0.0389674
Machala 4 0.0540342 0.0342350 0.0329013
Ambato 4 0.0958594 0.0428041 0.0395907
Resto urbano 4 0.2482496 0.0340682 0.0295659
Rural 4 0.1449645 0.0310516 0.0263603

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 8078 17.40530 0.000000 0
Guayaquil 1 8963 26.66518 0.000000 0
Cuenca 1 5856 33.76025 0.000000 0
Machala 1 6813 22.26626 0.000000 0
Ambato 1 4843 42.30849 7.722486 0
Resto urbano 1 26818 61.19025 29.767321 0
Rural 1 22531 30.49132 24.841330 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 8078 2.361692 3 18.24709 10.027235 8.145581 1.2998267 8.479822 0.00000
Guayaquil 8963 1.957126 3 23.77552 6.749972 13.031351 0.0780989 10.030124 0.00000
Cuenca 5856 2.647143 3 17.82787 13.575820 10.502049 4.6618852 8.674863 0.00000
Machala 6813 1.949592 3 23.55790 5.489505 14.912667 0.0000000 0.000000 0.00000
Ambato 4843 2.568309 3 19.67789 14.391906 11.686971 5.4098699 8.156102 0.00000
Resto urbano 26818 2.524006 3 12.75636 8.900738 13.517041 7.4017451 10.153628 0.00000
Rural 22531 3.365199 3 12.15658 14.846212 18.574409 21.0199281 10.696374 22.24491

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 8078 0.6199021 0.2371334 0.1271883
Guayaquil 8963 0.5595685 0.2188866 0.1030262
Cuenca 5856 0.8631384 0.3255807 0.1691607
Machala 6813 0.5098198 0.1948660 0.0965961
Ambato 4843 0.9920474 0.3575803 0.1804319
Resto urbano 26818 1.6437980 0.5394445 0.2632020
Rural 22531 3.0601191 0.6499786 0.3087172

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 8078 249.52783 106.44800 88.26749
Guayaquil 8963 198.91300 81.15329 63.90959
Cuenca 5856 125.26353 41.85270 31.45240
Machala 6813 26.30166 12.17738 10.20817
Ambato 4843 85.52068 23.15032 16.16602
Resto urbano 26818 2031.80814 172.91934 82.07120
Rural 22531 5531.76858 361.83165 189.79583