Dirección de Infraestructura Estadística y muestreo DINEM

ENEMDU Julio - Agosto - Septiembre 2025

#

1.- Preparación

Bases de viviendas

kable(viviendas)
Julio Agosto Septiembre
UPM 1288 1288 1288
Vivienda 8571 8575 8548
Hogar 8607 8607 8584 
# kable(upm_ac)
# kable(fc_ac)
# kable(ef_ac)

Bases de personas

‘r names(v1)’

kable(personas)
Julio Agosto Septiembre
UPM 1288 1288 1288
Vivienda 8571 8575 8548
Hogar 8607 8607 8584
Personas 27509 27580 27332 
# Guardar las bases tratadas de personas
saveRDS(p1, "./2025/Trimestrales/3_jul_sep/tratadas/personas/p1.rds")
saveRDS(p2, "./2025/Trimestrales/3_jul_sep/tratadas/personas/p2.rds")
saveRDS(p3, "./2025/Trimestrales/3_jul_sep/tratadas/personas/p3.rds")

2.- Preparación Factores Mensuales

Factores de expansión

  • Periodo 1 Julio
p1_fexp = readRDS(file = "./2025/Factores mensuales/07_Julio/FEXP_ENEMDU_T_202507.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 Agosto
p2_fexp = readRDS(file = "./2025/Factores mensuales/08_Agosto/FEXP_ENEMDU_T_202508.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 Septiembre
  p3_fexp = readRDS(file = "./2025/Factores mensuales/09_Septiembre/FEXP_ENEMDU_T_202509.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] 82421    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: Julio  - Agosto - Septiembre 2025", 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: Julio  - Agosto - Septiembre 2025", 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 : Julio  - Agosto - Septiembre") +
#   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: Julio  - Agosto - Septiembre") +
 #  # 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. 
##   22.71  120.45  255.00  397.61  493.50 5014.29
# 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. 
##   22.71  122.67  261.64  410.01  508.15 5014.29
# 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, "./2025/Trimestrales/3_jul_sep/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 
##  8211  8998  5742  6655  4735 26164 21916
table(base$dominio, useNA = "ifany")
## 
##    01    02    03    04    05    06    07    08    09    10    11    12 
##  8211  8998  5742  6655  4735 12030 10005  3772 10261  5909  5353   750

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 07 2783 0.3389356
01 08 2690 0.3276093
01 09 2738 0.3334551
02 07 2969 0.3299622
02 08 3095 0.3439653
02 09 2934 0.3260725
03 07 1975 0.3439568
03 08 1800 0.3134796
03 09 1967 0.3425636
04 07 2216 0.3329827
04 08 2250 0.3380917
04 09 2189 0.3289256
05 07 1567 0.3309398
05 08 1635 0.3453010
05 09 1533 0.3237592
06 07 8710 0.3329002
06 08 8742 0.3341232
06 09 8712 0.3329766
07 07 7289 0.3325881
07 08 7368 0.3361927
07 09 7259 0.3312192

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_rec45 = fexp_aju * delta)

Analisis estadístico descriptivo

summary(base$delta)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.3135  0.3312  0.3330  0.3334  0.3362  0.3453

Factor de expansión teórico acumulado

summary(base$fexp_acum_teo)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   40.170   85.101  132.557  164.883 1669.640
# 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_rec45)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.164   86.946  136.688  170.099 1669.640
# Grafico
ggplot(data = base,
       mapping = aes(x = fexp_rec45)) +
  geom_histogram(bins = 100,
                 position = 'identity',
                 alpha = 0.8) +
  labs(title = ' Distribución de los fexp_rec45',
       x = 'fexp_rec45',
       y = 'count',
       subtitle = 'Acumulada',
       caption = 'Encuesta Nacional de Empleo, Desempleo y Subempleo (ENEMDU). INEC - Ecuador.')

# Guardar la base
saveRDS(base, "./2025/Trimestrales/3_jul_sep/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_rec45)
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. 
##    7.679   41.206   87.182  136.688  170.958 1669.640 
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.263   87.182  136.688  171.495 1669.640 
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.206   87.182  136.688  171.178 1669.640 
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.206   87.182  136.688  171.125 1669.640 
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.206   87.182  136.688  170.958 1669.640 
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.206   87.182  136.688  170.958 1669.640

5.- Recorte Graficos

Boxplot del factor balanceado y del recortado final (4)

par(mfrow = c(1,2))
boxplot(base_fexp$fexp_rec45)
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_rec45)) +
  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 Julio  - Agosto - Septiembre 2025") +
  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 = "./2025/Trimestrales/3_jul_sep/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 Julio  - Agosto - Septiembre 2025") +
  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 = "./2025/Trimestrales/3_jul_sep/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_rec45,
             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 Julio  - Agosto - Septiembre 2025") +
  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 = "./2025/Trimestrales/3_jul_sep/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 
##      705     3154      750     3602      992     3372      943     3691 
## 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 
##      482     2193      478     2589      682     2503      655     2815 
## 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 
##      405     1789      355     2186     2939     9496     2705    11024 
## 07_2_1_1 07_2_1_2 07_2_2_1 07_2_2_2 
##     2455     8463     2283     8715
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_rec45,
                   nest = T)
options(survey.lonely.psu="adjust")
sum(weights(est_pob))
## [1] 11265969

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 705 123882.257 0.0589048 0
Quito Urbana Hombre > 15 años 01_1_1_2 3154 547671.786 0.0266554 0
Quito Urbana Mujer < 15 años 01_1_2_1 750 132206.561 0.0532510 0
Quito Urbana Mujer > 15 años 01_1_2_2 3602 622615.465 0.0239887 0
Guayaquil Urbana Hombre < 15 años 02_1_1_1 992 210039.824 0.0434658 0
Guayaquil Urbana Hombre > 15 años 02_1_1_2 3372 722333.309 0.0233997 0
Guayaquil Urbana Mujer < 15 años 02_1_2_1 943 197402.709 0.0418153 0
Guayaquil Urbana Mujer > 15 años 02_1_2_2 3691 782403.306 0.0197545 0
Cuenca Urbana Hombre < 15 años 03_1_1_1 482 21897.158 0.0650526 0
Cuenca Urbana Hombre > 15 años 03_1_1_2 2193 96181.140 0.0280283 0
Cuenca Urbana Mujer < 15 años 03_1_2_1 478 21957.189 0.0634061 0
Cuenca Urbana Mujer > 15 años 03_1_2_2 2589 113280.144 0.0275230 0
Machala Urbana Hombre < 15 años 04_1_1_1 682 19396.100 0.0500574 0
Machala Urbana Hombre > 15 años 04_1_1_2 2503 69013.024 0.0228471 0
Machala Urbana Mujer < 15 años 04_1_2_1 655 18728.701 0.0453681 0
Machala Urbana Mujer > 15 años 04_1_2_2 2815 77255.139 0.0206191 0
Ambato Urbana Hombre < 15 años 05_1_1_1 405 10204.832 0.0562574 0
Ambato Urbana Hombre > 15 años 05_1_1_2 1789 45226.666 0.0278001 0
Ambato Urbana Mujer < 15 años 05_1_2_1 355 9311.724 0.0765446 0
Ambato Urbana Mujer > 15 años 05_1_2_2 2186 54863.757 0.0228972 0
Resto urbano Urbana Hombre < 15 años 06_1_1_1 2939 534721.777 0.0349576 0
Resto urbano Urbana Hombre > 15 años 06_1_1_2 9496 1743895.301 0.0191767 0
Resto urbano Urbana Mujer < 15 años 06_1_2_1 2705 480967.906 0.0364379 0
Resto urbano Urbana Mujer > 15 años 06_1_2_2 11024 1964162.637 0.0174950 0
Rural Rural Hombre < 15 años 07_2_1_1 2455 269299.917 0.0327256 0
Rural Rural Hombre > 15 años 07_2_1_2 8463 1036853.458 0.0197806 0
Rural Rural Mujer < 15 años 07_2_2_1 2283 262831.011 0.0386684 0
Rural Rural Mujer > 15 años 07_2_2_2 8715 1077365.946 0.0194379 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_rec45))
table(compro_rec$f_rec)
## 
##     1 
## 25798

Poblaciones objetivo para la calibracion

 pob <- readRDS("./2025/Trimestrales/3_jul_sep/proyecciones/proyecciones.rds")

pob = pob %>%
  select(dom7, area, p02, gedad, ykn)
sum(pob$ykn)
## [1] 18897823
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 123882.257 215743 -91860.74 1.741516
Quito Urbana Hombre > 15 años 01_1_1_2 547671.786 802924 -255252.21 1.466068
Quito Urbana Mujer < 15 años 01_1_2_1 132206.561 239936 -107729.44 1.814857
Quito Urbana Mujer > 15 años 01_1_2_2 622615.465 867990 -245374.53 1.394103
Guayaquil Urbana Hombre < 15 años 02_1_1_1 210039.824 333685 -123645.18 1.588675
Guayaquil Urbana Hombre > 15 años 02_1_1_2 722333.309 1045775 -323441.69 1.447774
Guayaquil Urbana Mujer < 15 años 02_1_2_1 197402.709 354389 -156986.29 1.795259
Guayaquil Urbana Mujer > 15 años 02_1_2_2 782403.306 1112593 -330189.69 1.422020
Cuenca Urbana Hombre < 15 años 03_1_1_1 21897.158 48788 -26890.84 2.228052
Cuenca Urbana Hombre > 15 años 03_1_1_2 96181.140 155011 -58829.86 1.611657
Cuenca Urbana Mujer < 15 años 03_1_2_1 21957.189 56287 -34329.81 2.563489
Cuenca Urbana Mujer > 15 años 03_1_2_2 113280.144 178697 -65416.86 1.577479
Machala Urbana Hombre < 15 años 04_1_1_1 19396.100 34931 -15534.90 1.800929
Machala Urbana Hombre > 15 años 04_1_1_2 69013.024 110717 -41703.98 1.604291
Machala Urbana Mujer < 15 años 04_1_2_1 18728.701 35753 -17024.30 1.908995
Machala Urbana Mujer > 15 años 04_1_2_2 77255.139 113237 -35981.86 1.465754
Ambato Urbana Hombre < 15 años 05_1_1_1 10204.832 22816 -12611.17 2.235803
Ambato Urbana Hombre > 15 años 05_1_1_2 45226.666 76388 -31161.33 1.689004
Ambato Urbana Mujer < 15 años 05_1_2_1 9311.724 25455 -16143.28 2.733651
Ambato Urbana Mujer > 15 años 05_1_2_2 54863.757 85233 -30369.24 1.553539
Resto urbano Urbana Hombre < 15 años 06_1_1_1 534721.777 1046332 -511610.22 1.956778
Resto urbano Urbana Hombre > 15 años 06_1_1_2 1743895.301 2336210 -592314.70 1.339650
Resto urbano Urbana Mujer < 15 años 06_1_2_1 480967.906 1108832 -627864.09 2.305418
Resto urbano Urbana Mujer > 15 años 06_1_2_2 1964162.637 2475659 -511496.36 1.260414
Rural Rural Hombre < 15 años 07_2_1_1 269299.917 978210 -708910.08 3.632418
Rural Rural Hombre > 15 años 07_2_1_2 1036853.458 2041819 -1004965.54 1.969245
Rural Rural Mujer < 15 años 07_2_2_1 262831.011 966146 -703314.99 3.675921
Rural Rural Mujer > 15 años 07_2_2_2 1077365.946 2028267 -950901.05 1.882617

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_rec45,
                         total = vis$t,
                         method ="raking"),
         fexp_cal_hog_c_trim = fexp_rec45*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.5715  1.2004  1.4816  1.7579  1.9571  9.8490
summary(calibracion_hog_cepal$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    6.826   62.263  142.909  229.284  273.216 4868.001

Análisis estadístico: UPM

#UPM
calibracion_upm <- cal_upm  %>%
  mutate(g_upm = calib(Xs = as.matrix(.[,6:dim(.)[2]]),
                       d = fexp_rec45,
                       total = vis$t,
                       method ="raking"),
         fexp_cal_upm_trim = fexp_rec45*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.05247   0.74685   1.13907   1.61398   1.74638 182.28608
summary(calibracion_upm$fexp_cal_upm_trim)
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##     3.619    38.841    99.366   201.960   223.839 14888.011

Análisis estadístico: Persona

# Persona

calibracion_per <- cal_per  %>%
  mutate(g_per = calib(Xs = as.matrix(.[,7:dim(.)[2]]),
                       d = fexp_rec45,
                       total = vis$t,
                       method ="raking"),
         fexp_cal_per = fexp_rec45*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.260   1.394   1.577   1.740   1.909   3.676
summary(calibracion_per$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.26   70.55  147.73  229.28  276.98 3849.22

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 215743 215743 215743 215743 0.0000000 0.0000000 0.0000000
Quito Urbana Hombre > 15 años 01_1_1_2 802924 802924 802924 802924 0.0000000 0.0000000 0.0000000
Quito Urbana Mujer < 15 años 01_1_2_1 239936 239936 239936 239936 0.0000000 0.0000000 0.0000000
Quito Urbana Mujer > 15 años 01_1_2_2 867990 867990 867990 867990 0.0000000 0.0000000 0.0000000
Guayaquil Urbana Hombre < 15 años 02_1_1_1 333685 333685 333685 333685 0.0000000 0.0000000 0.0000000
Guayaquil Urbana Hombre > 15 años 02_1_1_2 1045775 1045775 1045775 1045775 0.0000000 0.0000000 0.0000000
Guayaquil Urbana Mujer < 15 años 02_1_2_1 354389 354389 354389 354389 0.0000000 0.0000000 0.0000000
Guayaquil Urbana Mujer > 15 años 02_1_2_2 1112593 1112593 1112593 1112593 0.0000000 0.0000000 0.0000000
Cuenca Urbana Hombre < 15 años 03_1_1_1 48788 48788 48788 48788 0.0000000 0.0000000 0.0000000
Cuenca Urbana Hombre > 15 años 03_1_1_2 155011 155011 155011 155011 0.0000000 0.0000000 0.0000000
Cuenca Urbana Mujer < 15 años 03_1_2_1 56287 56287 56287 56287 0.0000000 0.0000000 0.0000000
Cuenca Urbana Mujer > 15 años 03_1_2_2 178697 178697 178697 178697 0.0000000 0.0000000 0.0000000
Machala Urbana Hombre < 15 años 04_1_1_1 34931 34931 34931 34931 0.0000000 0.0000000 0.0000000
Machala Urbana Hombre > 15 años 04_1_1_2 110717 110717 110717 110717 0.0000000 0.0000000 0.0000000
Machala Urbana Mujer < 15 años 04_1_2_1 35753 35753 35753 35753 0.0000000 0.0000000 0.0000000
Machala Urbana Mujer > 15 años 04_1_2_2 113237 113237 113237 113237 0.0000000 0.0000000 0.0000000
Ambato Urbana Hombre < 15 años 05_1_1_1 22816 22816 22816 22816 0.0000000 0.0000000 0.0000000
Ambato Urbana Hombre > 15 años 05_1_1_2 76388 76388 76388 76388 0.0000000 0.0000000 0.0000000
Ambato Urbana Mujer < 15 años 05_1_2_1 25455 25455 25455 25455 0.0000000 0.0000000 0.0000000
Ambato Urbana Mujer > 15 años 05_1_2_2 85233 85233 85233 85233 0.0000000 0.0000000 0.0000000
Resto urbano Urbana Hombre < 15 años 06_1_1_1 1046332 1046332 1046332 1046332 0.0000000 0.0000000 0.0000000
Resto urbano Urbana Hombre > 15 años 06_1_1_2 2336210 2336210 2336210 2336210 0.0000000 0.0000000 0.0000000
Resto urbano Urbana Mujer < 15 años 06_1_2_1 1108832 1108832 1108832 1108832 0.0000000 0.0000000 0.0000000
Resto urbano Urbana Mujer > 15 años 06_1_2_2 2475659 2475659 2475659 2475659 0.0000000 0.0000000 0.0000000
Rural Rural Hombre < 15 años 07_2_1_1 978210 978210 978210 978210 0.0000641 0.0012911 0.0016370
Rural Rural Hombre > 15 años 07_2_1_2 2041819 2041819 2041819 2041819 0.0000660 0.0004628 0.0000000
Rural Rural Mujer < 15 años 07_2_2_1 966146 966146 966146 966146 0.0001169 0.0006116 0.0027712
Rural Rural Mujer > 15 años 07_2_2_2 2028267 2028267 2028267 2028267 0.0000900 0.0005014 0.0000000

Diferencia máxima: hogar integrado

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

Diferencia máxima: UPM

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

Diferencia máxima: Persona

max(comp$dif_comp_per)
## [1] 0.002771198

Analisis estadístico descriptivo

Sumatoria poblacion objetivo

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

Descriptivo Factor de expansión teorico

summary(base_fexp$fexp_acum_teo)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   40.170   85.101  132.557  164.883 1669.640
sum(base_fexp$fexp_acum_teo)
## [1] 10925449

Descriptivo Factor de expansión ajustado

summary(base_fexp$fexp_rec45)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    7.679   41.206   87.182  136.688  170.958 1669.640
sum(base_fexp$fexp_rec45)
## [1] 11265969

Descriptivo Factor de expansión calibrado (upm)

summary(base_fexp$fexp_cal_upm_trim)
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##     3.619    42.781   111.662   229.284   250.204 14888.011
sum(base_fexp$fexp_cal_upm_trim)
## [1] 18897823

Descriptivo Factor de expansión calibrado (hogar)

summary(base_fexp$fexp_cal_hog_c_trim)
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##    6.826   62.263  142.909  229.284  273.216 4868.001
sum(base_fexp$fexp_cal_hog_c_trim)
## [1] 18897823

Descriptivo Factor de expansión calibrado (persona)

summary(base_fexp$fexp_cal_per)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.26   70.55  147.73  229.28  276.98 3849.22
sum(base_fexp$fexp_cal_per)
## [1] 18897823

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_rec45,
             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 Julio  - Agosto - Septiembre 2025") +
  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 = "./2025/Trimestrales/3_jul_sep/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 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.0685779 0.0421284 0.0407000
Guayaquil 4 0.0457313 0.0327628 0.0321088
Cuenca 4 0.0923515 0.0497928 0.0460025
Machala 4 0.0563369 0.0358325 0.0347230
Ambato 4 0.1357544 0.0513923 0.0458748
Resto urbano 4 0.0814866 0.0303816 0.0270168
Rural 4 0.1556949 0.0327268 0.0276531

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 8211 22.44550 0.000000 0
Guayaquil 1 8998 18.42632 0.000000 0
Cuenca 1 5742 41.65796 0.000000 0
Machala 1 6655 28.44478 4.928625 0
Ambato 1 4735 30.83421 7.877508 0
Resto urbano 1 26164 58.51170 30.698670 0
Rural 1 21916 30.46176 9.915131 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 8211 1.814857 3 22.49422 2.301790 14.809402 0.000000 0.9499452 0.00000
Guayaquil 8998 1.795259 3 23.42743 3.056235 9.924428 0.000000 0.0000000 0.00000
Cuenca 5742 2.563489 3 16.77116 11.267851 10.431905 4.057820 0.0000000 0.00000
Machala 6655 1.908995 3 26.38618 6.882044 14.229902 0.000000 9.8422239 0.00000
Ambato 4735 2.733651 3 10.89757 9.440338 9.440338 4.350581 7.4973601 0.00000
Resto urbano 26164 2.305418 3 17.37502 12.165571 14.772206 3.221984 10.3386332 0.00000
Rural 21916 3.675921 3 13.47874 18.009673 15.751050 25.821318 10.4170469 21.61891

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 8211 0.4237839 0.1854792 0.0933039
Guayaquil 8998 0.4208298 0.1566575 0.0777450
Cuenca 5742 0.9041870 0.3500852 0.1779787
Machala 6655 0.5467282 0.1998950 0.0911323
Ambato 4735 0.9465180 0.3605412 0.1910449
Resto urbano 26164 1.3819535 0.4904897 0.2381098
Rural 21916 3.3830262 0.6201292 0.3099225

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_rec45)^2/fexp_rec45)/n,
            dist_g_hog = sum((fexp_cal_hog_c_trim - fexp_rec45)^2/fexp_rec45)/n,
            dist_g_per = sum((fexp_cal_per - fexp_rec45)^2/fexp_rec45)/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 8211 121.92986 55.12703 45.25247
Guayaquil 8998 125.87704 62.08190 53.54599
Cuenca 5742 123.79124 39.81042 27.94464
Machala 6655 29.98928 12.67326 10.49998
Ambato 4735 94.58388 24.81710 17.28671
Resto urbano 26164 771.53288 132.84785 62.81545
Rural 21916 6460.83959 443.57880 253.76449