Muestreo Aleatorio Simple - Cali

1 1. Lectura del marco

rm(list = ls())

if(!require(survey)) install.packages("survey")
if(!require(sampling)) install.packages("sampling")

library(survey)
library(sampling)

base <- readRDS("C:/Users/equipo/Desktop/aa/Copia de Marco.rds")

resumen_base <- data.frame(
  Base = "Marco original",
  Filas = nrow(base),
  Columnas = ncol(base)
)

knitr::kable(resumen_base, caption = "Resumen general del marco poblacional")

Resumen general del marco poblacional

Base	Filas	Columnas
Marco original	546212	82

2 2. Base de estudio: Cali

# Código DANE de Cali: 76001
base_cali <- subset(base, COLE_COD_MCPIO_UBICACION == 76001)

# Variable original del ejemplo: colegio académico
base_cali$academico <- ifelse(base_cali$COLE_CARACTER == "ACADÉMICO", 1, 0)

# Variable adicional no asociada a puntajes: colegio oficial
base_cali$oficial <- ifelse(
  trimws(toupper(as.character(base_cali$COLE_NATURALEZA))) == "OFICIAL",
  1,
  0
)

# Variables categóricas usadas en las estimaciones
base_cali$DESEMP_INGLES <- as.factor(base_cali$DESEMP_INGLES)
base_cali$ESTU_GENERACION.E <- as.factor(base_cali$ESTU_GENERACION.E)

resumen_cali <- data.frame(
  Base = "Cali",
  Filas = nrow(base_cali),
  Columnas = ncol(base_cali),
  Proporcion_en_marco = round(nrow(base_cali) / nrow(base), 4)
)

knitr::kable(resumen_cali, caption = "Resumen de la base filtrada para Cali")

Resumen de la base filtrada para Cali

Base	Filas	Columnas	Proporcion_en_marco
Cali	16666	84	0.0305

2.1 2.1 Distribuciones principales

tabla_naturaleza <- as.data.frame(table(base_cali$COLE_NATURALEZA, useNA = "ifany"))
names(tabla_naturaleza) <- c("Naturaleza del colegio", "Frecuencia")

knitr::kable(tabla_naturaleza, caption = "Distribución de la naturaleza del colegio")

Distribución de la naturaleza del colegio

Naturaleza del colegio	Frecuencia
NO OFICIAL	5065
OFICIAL	11601

tabla_oficial <- as.data.frame(table(base_cali$oficial, useNA = "ifany"))
names(tabla_oficial) <- c("Oficial", "Frecuencia")

tabla_oficial$Oficial <- ifelse(
  as.character(tabla_oficial$Oficial) == "1",
  "Oficial",
  "No oficial"
)

knitr::kable(tabla_oficial, caption = "Distribución de la variable indicadora oficial")

Distribución de la variable indicadora oficial

Oficial	Frecuencia
No oficial	5065
Oficial	11601

tabla_ingles <- as.data.frame(table(base_cali$DESEMP_INGLES, useNA = "ifany"))
names(tabla_ingles) <- c("Desempeño en inglés", "Frecuencia")

knitr::kable(tabla_ingles, caption = "Distribución del desempeño en inglés")

Distribución del desempeño en inglés

Desempeño en inglés	Frecuencia
A-	7629
A1	5194
A2	2781
B+	107
B1	955

tabla_generacion <- as.data.frame(table(base_cali$ESTU_GENERACION.E, useNA = "ifany"))
names(tabla_generacion) <- c("Generación E", "Frecuencia")

knitr::kable(tabla_generacion, caption = "Distribución de la variable ESTU_GENERACION.E")

Distribución de la variable ESTU_GENERACION.E

Generación E	Frecuencia
GENERACION E - EXCELENCIA DEPARTAMENTAL	1
GENERACION E - EXCELENCIA NACIONAL	93
GENERACION E - GRATUIDAD	5426
NO	11146

3 3. Tamaño de muestra

n.mas <- function(tipo, N, s = NULL, e, p = NULL, alpha){
  
  if(tipo == "t"){
    n <- round(
      (qnorm(1 - alpha/2)^2 * N^2 * s^2) /
        (e^2 + qnorm(1 - alpha/2)^2 * N * s^2),
      0
    )
    return(n)
  }
  
  if(tipo == "m"){
    n <- round(
      (qnorm(1 - alpha/2)^2 * s^2) /
        (e^2 + (qnorm(1 - alpha/2)^2 * s^2 / N)),
      0
    )
    return(n)
  }
  
  if(tipo == "p"){
    n <- round(
      (qnorm(1 - alpha/2)^2 * (N/(N - 1)) * p * (1 - p)) /
        (e^2 + (qnorm(1 - alpha/2)^2 * (N/(N - 1)) * p * (1 - p) * (1/N))),
      0
    )
    return(n)
  }
}

N <- nrow(base_cali)
alpha <- 0.05

escenarios_n <- data.frame(
  Tipo = c("Proporción", "Proporción", "Proporción"),
  N = N,
  p = c(0.5, 0.5, 0.3),
  e = c(0.05, 0.04, 0.04),
  alpha = alpha
)

escenarios_n$n_estimado <- mapply(
  FUN = function(N, p, e, alpha){
    n.mas(tipo = "p", N = N, e = e, p = p, alpha = alpha)
  },
  N = escenarios_n$N,
  p = escenarios_n$p,
  e = escenarios_n$e,
  alpha = escenarios_n$alpha
)

knitr::kable(escenarios_n, caption = "Escenarios para el cálculo del tamaño de muestra")

Escenarios para el cálculo del tamaño de muestra

Tipo	N	p	e	alpha	n_estimado
Proporción	16666	0.5	0.05	0.05	376
Proporción	16666	0.5	0.04	0.05	579
Proporción	16666	0.3	0.04	0.05	489

# Se toma el segundo escenario, equivalente al usado en la estructura original.
n_calculado <- escenarios_n$n_estimado[2]

n_seleccionado <- data.frame(
  Escenario = "p = 0.5, e = 0.04, alpha = 0.05",
  n = n_calculado
)

knitr::kable(n_seleccionado, caption = "Tamaño de muestra seleccionado")

Tamaño de muestra seleccionado

Escenario	n
p = 0.5, e = 0.04, alpha = 0.05	579

4 4. Selección de la muestra

4.1 4.1 Coordinado negativo

s.mas <- function(base, n, seed){
  N <- nrow(base)
  set.seed(seed)
  base$u <- runif(nrow(base))
  base <- base[with(base, order(u)), ]
  base <- base[1:n, ]
  base$pik <- n/N
  return(base)
}

n <- n_calculado
seed <- 123

muestra <- s.mas(base_cali, n, seed)

resumen_muestra <- data.frame(
  Metodo = "Coordinado negativo",
  N_poblacion = nrow(base_cali),
  n_muestra = nrow(muestra),
  Probabilidad_inclusion = unique(round(muestra$pik, 6)),
  Factor_expansion = unique(round(1/muestra$pik, 4))
)

knitr::kable(resumen_muestra, caption = "Resumen de la muestra seleccionada por coordinado negativo")

Resumen de la muestra seleccionada por coordinado negativo

Metodo	N_poblacion	n_muestra	Probabilidad_inclusion	Factor_expansion
Coordinado negativo	16666	579	0.034741	28.7841

4.2 4.2 Selección y rechazo

Fan_Muller <- function(base, n, seed){
  N <- nrow(base)
  j <- 0
  m <- numeric(N)
  set.seed(seed)
  
  for(k in 1:N){
    if(runif(1) < (n - j)/(N - k + 1)){
      j <- j + 1
      m[k] <- 1
    }
  }
  
  return(m)
}

m <- Fan_Muller(base_cali, n, seed)

muestra2 <- base_cali[which(m == 1), ]

resumen_muestra2 <- data.frame(
  Metodo = "Selección y rechazo",
  N_poblacion = nrow(base_cali),
  n_muestra = nrow(muestra2)
)

knitr::kable(resumen_muestra2, caption = "Resumen de la muestra seleccionada por selección y rechazo")

Resumen de la muestra seleccionada por selección y rechazo

Metodo	N_poblacion	n_muestra
Selección y rechazo	16666	579

5 5. El pi-estimador bajo el MAS en una etapa

salida <- function(est, alpha){
  est <- as.data.frame(est)
  names(est)[2] <- "se"
  est$cv <- 100 * (est$se / est[, 1])
  est$ic_low <- est[, 1] - qnorm(1 - alpha/2) * est$se
  est$ic_upp <- est[, 1] + qnorm(1 - alpha/2) * est$se
  
  cols_numericas <- sapply(est, is.numeric)
  est[cols_numericas] <- lapply(est[cols_numericas], round, 2)
  
  return(est)
}

N <- nrow(base_cali)

muestra$ind <- rep(1, nrow(muestra))
muestra$Fexp <- 1 / muestra$pik
muestra$fpc <- N

dsgn <- svydesign(
  id = ~1,
  fpc = ~fpc,
  data = muestra,
  weights = ~Fexp
)

resumen_diseno <- data.frame(
  Diseno = "MAS sin reemplazo",
  N_poblacion = N,
  n_muestra = nrow(muestra),
  Factor_expansion = round(unique(muestra$Fexp), 4)
)

knitr::kable(resumen_diseno, caption = "Resumen del diseño muestral")

Resumen del diseño muestral

Diseno	N_poblacion	n_muestra	Factor_expansion
MAS sin reemplazo	16666	579	28.7841

5.1 5.1 Estimación del total

est <- svytotal(~academico, dsgn, deff = TRUE, na.rm = TRUE)

alpha <- 0.05
tabla <- salida(est, alpha)

knitr::kable(tabla, caption = "Estimación del total de registros asociados a colegios académicos")

Estimación del total de registros asociados a colegios académicos

	total	se	deff	cv	ic_low	ic_upp
academico	2273.94	233.78	1	10.28	1815.74	2732.15

5.2 5.2 Estimación de la media

est1 <- svymean(~PUNT_MATEMATICAS, dsgn, deff = TRUE, na.rm = TRUE)

tabla1 <- salida(est1, alpha)

knitr::kable(tabla1, caption = "Estimación de la media del puntaje en matemáticas")

Estimación de la media del puntaje en matemáticas

	mean	se	deff	cv	ic_low	ic_upp
PUNT_MATEMATICAS	49.57	0.46	1	0.93	48.67	50.47

5.3 5.3 Estimación de proporción

est2 <- svymean(~DESEMP_INGLES, dsgn, deff = TRUE, na.rm = TRUE)

tabla2 <- salida(est2, alpha)

knitr::kable(tabla2, caption = "Estimación de proporciones para desempeño en inglés")

Estimación de proporciones para desempeño en inglés

	mean	se	deff	cv	ic_low	ic_upp
DESEMP_INGLESA-	0.44	0.02	1	4.61	0.40	0.48
DESEMP_INGLESA1	0.34	0.02	1	5.73	0.30	0.37
DESEMP_INGLESA2	0.15	0.01	1	9.92	0.12	0.17
DESEMP_INGLESB+	0.01	0.00	1	36.94	0.00	0.02
DESEMP_INGLESB1	0.07	0.01	1	15.42	0.05	0.09

5.4 5.4 Estimación de más de una variable

est3 <- svymean(
  ~PUNT_GLOBAL +
    PUNT_LECTURA_CRITICA +
    PUNT_MATEMATICAS +
    PUNT_C_NATURALES +
    PUNT_SOCIALES_CIUDADANAS +
    PUNT_INGLES,
  dsgn,
  na.rm = TRUE
)

tabla3 <- salida(est3, alpha)

knitr::kable(tabla3, caption = "Estimación de medias para diferentes puntajes")

Estimación de medias para diferentes puntajes

	mean	se	cv	ic_low	ic_upp
PUNT_GLOBAL	245.28	1.96	0.80	241.44	249.13
PUNT_LECTURA_CRITICA	52.51	0.42	0.81	51.68	53.34
PUNT_MATEMATICAS	49.57	0.46	0.93	48.67	50.47
PUNT_C_NATURALES	48.09	0.41	0.86	47.28	48.90
PUNT_SOCIALES_CIUDADANAS	46.04	0.48	1.04	45.10	46.98
PUNT_INGLES	49.10	0.50	1.01	48.13	50.08

6 6. Estimaciones por dominio usando MAS

6.1 6.1 Estimación del tamaño de un dominio

est4 <- svyby(
  ~ind,
  ~ESTU_GENERACION.E,
  dsgn,
  svytotal,
  na.rm = TRUE
)

est4_tab <- as.data.frame(est4)
est4_aux <- est4_tab[, -1]

tabla4 <- salida(est4_aux, alpha)
tabla4 <- cbind(Dominio = est4_tab$ESTU_GENERACION.E, tabla4)

knitr::kable(tabla4, caption = "Estimación del tamaño del dominio según ESTU_GENERACION.E")

Estimación del tamaño del dominio según ESTU_GENERACION.E

	Dominio	ind	se	cv	ic_low	ic_upp
GENERACION E - EXCELENCIA NACIONAL	GENERACION E - EXCELENCIA NACIONAL	28.78	28.28	98.25	-26.64	84.21
GENERACION E - GRATUIDAD	GENERACION E - GRATUIDAD	5728.04	323.47	5.65	5094.06	6362.02
NO	NO	10909.18	323.85	2.97	10274.44	11543.91

6.2 6.2 Estimación del total de una variable asociada a un dominio

est5 <- svyby(
  ~academico,
  ~ESTU_GENERACION.E,
  dsgn,
  svytotal,
  deff = TRUE,
  na.rm = TRUE
)

est5_tab <- as.data.frame(est5)
est5_aux <- est5_tab[, -1]

tabla5 <- salida(est5_aux, alpha)
tabla5 <- cbind(Dominio = est5_tab$ESTU_GENERACION.E, tabla5)

knitr::kable(tabla5, caption = "Estimación del total de colegios académicos por dominio")

Estimación del total de colegios académicos por dominio

	Dominio	academico	se	DEff.academico	cv	ic_low	ic_upp
GENERACION E - EXCELENCIA NACIONAL	GENERACION E - EXCELENCIA NACIONAL	0.00	0.00	NA	NaN	0.00	0.00
GENERACION E - GRATUIDAD	GENERACION E - GRATUIDAD	1151.36	172.72	1.16	15.00	812.85	1489.88
NO	NO	1122.58	170.70	1.04	15.21	788.01	1457.15

6.3 6.3 Estimación de la media de una variable asociada a un dominio

est6 <- svyby(
  ~PUNT_MATEMATICAS,
  ~ESTU_GENERACION.E,
  dsgn,
  svymean,
  deff = TRUE,
  na.rm = TRUE
)

est6_tab <- as.data.frame(est6)
est6_aux <- est6_tab[, -1]

tabla6 <- salida(est6_aux, alpha)
tabla6 <- cbind(Dominio = est6_tab$ESTU_GENERACION.E, tabla6)

knitr::kable(tabla6, caption = "Estimación de la media de matemáticas por dominio")

Estimación de la media de matemáticas por dominio

	Dominio	PUNT_MATEMATICAS	se	DEff.PUNT_MATEMATICAS	cv	ic_low	ic_upp
GENERACION E - EXCELENCIA NACIONAL	GENERACION E - EXCELENCIA NACIONAL	72.00	0.00	NA	0.00	72.00	72.00
GENERACION E - GRATUIDAD	GENERACION E - GRATUIDAD	46.31	0.75	1	1.63	44.83	47.78
NO	NO	51.23	0.56	1	1.09	50.13	52.33

6.4 6.4 Estimación de proporción de una variable asociada a un dominio

salida_prop_dom <- function(est, var_cat, dom_var, alpha){
  
  est <- as.data.frame(est)
  
  p_cols <- names(est)[startsWith(names(est), var_cat)]
  p_cols <- p_cols[!startsWith(p_cols, "se.")]
  
  se_cols <- paste0("se.", p_cols)
  
  tab2 <- NULL
  
  for(j in seq_along(p_cols)){
    
    categoria <- gsub(var_cat, "", p_cols[j])
    
    tab <- data.frame(
      dominio = est[[dom_var]],
      categoria = categoria,
      p = est[[p_cols[j]]],
      se = est[[se_cols[j]]]
    )
    
    tab$cv <- ifelse(tab$p == 0, NA, 100 * tab$se / tab$p)
    tab$ic_low <- tab$p - qnorm(1 - alpha/2) * tab$se
    tab$ic_upp <- tab$p + qnorm(1 - alpha/2) * tab$se
    
    tab2 <- rbind(tab2, tab)
  }
  
  cols_numericas <- sapply(tab2, is.numeric)
  tab2[cols_numericas] <- lapply(tab2[cols_numericas], round, 4)
  
  return(tab2)
}

est7 <- svyby(
  ~DESEMP_INGLES,
  ~ESTU_GENERACION.E,
  dsgn,
  svymean,
  deff = TRUE,
  na.rm = TRUE
)

tabla7 <- salida_prop_dom(
  est = est7,
  var_cat = "DESEMP_INGLES",
  dom_var = "ESTU_GENERACION.E",
  alpha = 0.05
)

knitr::kable(tabla7, caption = "Estimación de proporciones del desempeño en inglés por dominio")

Estimación de proporciones del desempeño en inglés por dominio

dominio	categoria	p	se	cv	ic_low	ic_upp
GENERACION E - EXCELENCIA NACIONAL	A-	0.0000	0.0000	NA	0.0000	0.0000
GENERACION E - GRATUIDAD	A-	0.5628	0.0346	6.1436	0.4950	0.6306
NO	A-	0.3773	0.0245	6.4888	0.3293	0.4253
GENERACION E - EXCELENCIA NACIONAL	A1	0.0000	0.0000	NA	0.0000	0.0000
GENERACION E - GRATUIDAD	A1	0.3317	0.0328	9.8952	0.2673	0.3960
NO	A1	0.3404	0.0239	7.0316	0.2935	0.3873
GENERACION E - EXCELENCIA NACIONAL	A2	0.0000	0.0000	NA	0.0000	0.0000
GENERACION E - GRATUIDAD	A2	0.0754	0.0184	24.4137	0.0393	0.1114
NO	A2	0.1821	0.0195	10.7062	0.1439	0.2203
GENERACION E - EXCELENCIA NACIONAL	B+	0.0000	0.0000	NA	0.0000	0.0000
GENERACION E - GRATUIDAD	B+	0.0101	0.0070	69.1813	-0.0036	0.0237
NO	B+	0.0132	0.0058	43.6846	0.0019	0.0245
GENERACION E - EXCELENCIA NACIONAL	B1	1.0000	0.0000	0.0000	1.0000	1.0000
GENERACION E - GRATUIDAD	B1	0.0201	0.0098	48.6696	0.0009	0.0393
NO	B1	0.0871	0.0142	16.3553	0.0592	0.1150

7 7. Estimación adicional con una variable no asociada a puntajes

En esta sección se utiliza la variable COLE_NATURALEZA, a partir de la cual se construyó la variable indicadora oficial. Esta variable toma el valor de 1 cuando el colegio es oficial y 0 en caso contrario.

7.1 7.1 Estimación del total de registros asociados a colegios oficiales

est_oficial_total <- svytotal(
  ~oficial,
  dsgn,
  deff = TRUE,
  na.rm = TRUE
)

tabla_oficial_total <- salida(est_oficial_total, alpha)

knitr::kable(tabla_oficial_total, caption = "Estimación del total de registros asociados a colegios oficiales")

Estimación del total de registros asociados a colegios oficiales

	total	se	deff	cv	ic_low	ic_upp
oficial	11628.78	312.77	1	2.69	11015.77	12241.79

7.2 7.2 Estimación de la proporción de registros asociados a colegios oficiales

est_oficial_prop <- svymean(
  ~oficial,
  dsgn,
  deff = TRUE,
  na.rm = TRUE
)

tabla_oficial_prop <- salida(est_oficial_prop, alpha)

knitr::kable(tabla_oficial_prop, caption = "Estimación de la proporción de registros asociados a colegios oficiales")

Estimación de la proporción de registros asociados a colegios oficiales

	mean	se	deff	cv	ic_low	ic_upp
oficial	0.7	0.02	1	2.69	0.66	0.73

7.3 7.3 Estimación de la proporción de colegios oficiales por dominio

est_oficial_dom <- svyby(
  ~oficial,
  ~ESTU_GENERACION.E,
  dsgn,
  svymean,
  deff = TRUE,
  na.rm = TRUE
)

est_oficial_dom_tab <- as.data.frame(est_oficial_dom)
est_oficial_dom_aux <- est_oficial_dom_tab[, -1]

tabla_oficial_dom <- salida(est_oficial_dom_aux, alpha)
tabla_oficial_dom <- cbind(Dominio = est_oficial_dom_tab$ESTU_GENERACION.E, tabla_oficial_dom)

knitr::kable(tabla_oficial_dom, caption = "Estimación de la proporción de colegios oficiales por dominio")

Estimación de la proporción de colegios oficiales por dominio

	Dominio	oficial	se	DEff.oficial	cv	ic_low	ic_upp
GENERACION E - EXCELENCIA NACIONAL	GENERACION E - EXCELENCIA NACIONAL	1.00	0.00	NA	0.00	1.00	1.00
GENERACION E - GRATUIDAD	GENERACION E - GRATUIDAD	0.69	0.03	1	4.63	0.63	0.76
NO	NO	0.70	0.02	1	3.31	0.65	0.74

8 8. Interpretación y conclusiones

A partir del Muestreo Aleatorio Simple aplicado a la ciudad de Cali, se observa que la media estimada del puntaje en matemáticas fue de aproximadamente 49.57 puntos. El intervalo de confianza se ubicó entre 48.67 y 50.47, lo cual permite afirmar que el promedio poblacional esperado para esta variable se encuentra dentro de ese rango. Además, el coeficiente de variación fue de 0.93%, lo que indica que la estimación presenta un nivel de precisión adecuado.

En cuanto a la variable institucional oficial, se estimó que aproximadamente 70% de los registros pertenecen a colegios oficiales. En términos de conteo poblacional, esto equivale aproximadamente a 1.162878^{4} registros asociados a instituciones oficiales dentro de la población de Cali. El intervalo de confianza de la proporción se ubicó entre 66% y 73%, lo que permite observar la posible variación de esta característica en la población.

Respecto al desempeño en inglés, la categoría con mayor proporción estimada fue A-, con una participación aproximada de 44.04%. Esto sugiere que, dentro de la población analizada, dicha categoría concentra la mayor parte de los estudiantes en relación con el nivel de desempeño en inglés.

En las estimaciones por dominio, se observó que el grupo con mayor tamaño estimado dentro de la variable ESTU_GENERACION.E fue NO. Esto indica que dicho dominio tiene mayor representación dentro de la población estimada de Cali, por lo que sus resultados tienen un peso importante dentro del análisis general.