0. Librerías

library(dplyr)

## 
## Adjuntando el paquete: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(gt)
library(e1071)

1. Leer datos

df <- read.csv(
  "waterPollution.csv",
  sep = ",",
  stringsAsFactors = FALSE
)

2. Selección de variable aleatoria

# -------------------------
# Extraer variable y discretizar por redondeo
# -------------------------
Migraciones <- round(df$netMigration_2011_2018)

# Eliminar valores faltantes
Migraciones <- na.omit(Migraciones)

3. Tabla de disitribución de frecuencias

# 3. Tabla de distribución de frecuencias sincronizada con la gráfica
valores_completos <- c(18927, 21257, 62334, 75808, 325435, 582211)
ni_completos <- c(355, 479, 261, 9661, 3957, 541)
total_n_completo <- sum(ni_completos) # Total = 15,254

# ----------------------------
# TABLA N°4 DE FRECUENCIAS (Sincronizada)
# ----------------------------
tabla_base_completa <- data.frame(
  Migracion = c("[18k - 21k]", "(21k - 62k]", "(62k - 75k]", 
                "(75k - 325k]", "(325k - 450k]", "(450k - 582k]"),
  ni = ni_completos
)

# Cálculos de frecuencias sobre el total 
tabla_base_completa$hi <- round((tabla_base_completa$ni / total_n_completo) * 100, 2)
tabla_base_completa$Ni_asc <- cumsum(tabla_base_completa$ni)
tabla_base_completa$Hi_asc <- round((tabla_base_completa$Ni_asc / total_n_completo) * 100, 2)
tabla_base_completa$Ni_dsc <- rev(cumsum(rev(tabla_base_completa$ni)))
tabla_base_completa$Hi_dsc <- round((tabla_base_completa$Ni_dsc / total_n_completo) * 100, 2)

# Fila de totales
fila_total_completa <- data.frame(
  Migracion = "TOTAL", ni = total_n_completo, hi = 100.00,
  Ni_asc = NA, Hi_asc = NA, Ni_dsc = NA, Hi_dsc = NA
)
tabla_final_completa <- rbind(tabla_base_completa, fila_total_completa)
tabla_final_completa[is.na(tabla_final_completa)] <- ""

# Renderizar tabla con gt
tabla_elegante_completa <- tabla_final_completa %>%
  gt() %>%
  tab_header(
    title = md("**Tabla N°1**"),
    subtitle = md("**Distribución de frecuencias simplificada de la 
                  migración neta, en el estudio de la calidad de agua en Europa 
                  (1991-2017)**")
  ) %>%
  cols_label(
    Migracion = md("**Intervalos de Migración**"), ni = md("**ni**"), hi = md("**hi (%)**"),
    Ni_asc = md("**Ni ↑**"), Hi_asc = md("**Hi ↑ (%)**"),
    Ni_dsc = md("**Ni ↓**"), Hi_dsc = md("**Hi ↓ (%)**")
  ) %>%
  cols_align(align = "center", columns = everything()) %>%
  tab_style(
    style = list(cell_text(weight = "bold"), cell_borders(sides = "top", color = "black", weight = px(2))),
    locations = cells_body(rows = Migracion == "TOTAL")
  ) %>%
  opt_row_striping()

# Visualizar Tabla Completa
tabla_elegante_completa

Intervalos de Migración	ni	hi (%)	Ni ↑	Hi ↑ (%)	Ni ↓	Hi ↓ (%)
Tabla N°1
Distribución de frecuencias simplificada de la migración neta, en el estudio de la calidad de agua en Europa (1991-2017)
[18k - 21k]	355	2.33	355	2.33	15254	100
(21k - 62k]	479	3.14	834	5.47	14899	97.67
(62k - 75k]	261	1.71	1095	7.18	14420	94.53
(75k - 325k]	9661	63.33	10756	70.51	14159	92.82
(325k - 450k]	3957	25.94	14713	96.45	4498	29.49
(450k - 582k]	541	3.55	15254	100	541	3.55
TOTAL	15254	100.00

4. Gráfica de distribución de frecuencias

# ----------------
# GRÁFICA hi N°1  
# ---------------
par(mar = c(7, 5, 4, 2) + 0.1)

# etiquetas_cortas <- c("18.9K", "21.3K", "62.3K", "75.8K", "325.4K", "582.2K")

barras_hi_completo <- barplot(
  height = tabla_base_completa$hi,
  names.arg = c("[18k - 21k]", "(21k - 62k]", "(62k - 75k]", "(75k - 325k]", "(325k - 450k]", "(450k - 582k]"),
  col = "skyblue",
  border = "black",
  main = "Gráfica N°1: Distribución porcentual de la migración neta en el \nestudio de la calidad de agua en Europa (1991-2017)",
  xlab = "", ylab = "Porcentaje (%)",
  ylim = c(0, max(tabla_base_completa$hi) * 1.25),
  las = 1, cex.names = 0.7, font.lab = 2
)
title(xlab = "Migración neta", line = 5, font.lab = 2)

5. Conjetura

Al observar la distribución de frecuencias de la migración neta, se aprecia una estabilidad inicial en los tres primeros intervalos, seguida de un incremento drástico en los valores restantes. Debido a este comportamiento bimodal y diferenciado, se plantea la conjetura de que el fenómeno no puede ser explicado por un único modelo, optando por una partición: un modelo Binomial para el tramo de menor magnitud y un modelo Geométrico para el tramo de mayor magnitud.

6. Cálculo de parámetros

6.1 Modelo Binomial

# ============================================
# CÁLCULO DE PARÁMETROS DEL MODELO BINOMIAL
# ============================================

# 1. Extracción de datos de la tabla unificada (Primeras 3 categorías)
ni_moderada_unif <- tabla_base_completa$ni[1:3]
total_n_bin_unif <- sum(ni_moderada_unif)

# 2. Definición de índices y número de ensayos
X_indices_bin <- 0:2
n_ensayos_bin <- 2

# 3. Cálculo de la Media Observada (Esperanza Muestral)
media_obs_bin <- sum(X_indices_bin * ni_moderada_unif) / total_n_bin_unif

# 4. Estimación del parámetro p (Probabilidad de éxito)
prob_p_bin <- media_obs_bin / n_ensayos_bin

# 5. Cálculo de las Probabilidades Teóricas del Modelo (%)
P_Binomial_Final <- dbinom(X_indices_bin, size = n_ensayos_bin, prob = prob_p_bin) * 100

# =========================================
# IMPRESIÓN DE RESULTADOS PARA EL INFORME
# =========================================
cat("--- RESULTADOS MODELO BINOMIAL ---\n")

## --- RESULTADOS MODELO BINOMIAL ---

cat("Total de observaciones del tramo (N):", total_n_bin_unif, "\n")

## Total de observaciones del tramo (N): 1095

cat("Media observada (x_barra):", round(media_obs_bin, 4), "\n")

## Media observada (x_barra): 0.9142

cat("Parámetro p estimado:", round(prob_p_bin, 4), "\n")

## Parámetro p estimado: 0.4571

cat("\nProbabilidades Teóricas Calculadas por el Modelo:\n")

## 
## Probabilidades Teóricas Calculadas por el Modelo:

for(i in 1:length(X_indices_bin)) {
  cat(" Categoría X =", X_indices_bin[i], ":", round(P_Binomial_Final[i], 2), "%\n")
}

##  Categoría X = 0 : 29.48 %
##  Categoría X = 1 : 49.63 %
##  Categoría X = 2 : 20.89 %

6.2 Modelo Geométrico

# ================================================
# 6. CÁLCULO DEL PARÁMETRO DEL MODELO GEOMÉTRICO 
# ================================================

# Extraemos las frecuencias absolutas de las últimas 3 categorías
ni_geom <- tabla_base_completa$ni[4:6]
N_geom <- sum(ni_geom)

# Calculamos los porcentajes locales para que estas 3 barras sumen el 100%
hi_geom <- (ni_geom / N_geom) * 100

# Mapeamos los 3 intervalos a valores discretos (0, 1, 2)
x_mapped_geom <- 0:2

# Usamos la probabilidad real local en decimales
p_s_data_geom <- hi_geom / 100

# Calculamos la esperanza matemática local (media)
media_x_geom <- sum(x_mapped_geom * p_s_data_geom)

# Calculamos el parámetro del modelo geométrico local (p)
prob_geom <- 1 / (1 + media_x_geom)

# Mostramos el resultado
cat("Media =", round(media_x_geom, 4), "\n")

## Media = 0.3559

cat("Parámetro del modelo geométrico (p) =", round(prob_geom, 4), "\n")

## Parámetro del modelo geométrico (p) = 0.7375

7. Sobreposición de la realidad con el modelo

7.1 Modelo binomial

# -------------------------------------------------------------
# GRÁFICA N°2: Comparación Realidad vs Modelo Binomial con Intervalos
# -------------------------------------------------------------
par(mar = c(7, 5, 4, 2) + 0.1) # Margen inferior ampliado para los intervalos

# 2. Porcentajes reales observados en el tramo moderado 
hi_real_bin_unif <- (ni_moderada_unif / total_n_bin_unif) * 100

# 3. Determinar el límite máximo en el eje Y para dar espacio a la leyenda
max_y_bin <- max(max(hi_real_bin_unif), max(P_Binomial_Final))

# Definir los primeros tres intervalos para que coincidan con la tabla y gráfica 1
etiquetas_primeros_tres <- c("[18k - 21k]", "(21k - 62k]", "(62k - 75k]")

# 4. Generar el gráfico de barras agrupadas base 
grafica_bin_final <- barplot(
  rbind(hi_real_bin_unif, P_Binomial_Final),         
  beside = TRUE,        
  main = "Gráfica N°2: Distribución porcentual de la migración neta en el \nestudio de la calidad de agua en Europa (1991-2017)",        
  ylab = "Probabilidad",         
  names.arg = etiquetas_primeros_tres, 
  col = c("#B0C4DE", "#2E86C1"), 
  ylim = c(0, max_y_bin + 20),         
  las = 1,          
  cex.names = 0.7,        
  cex.main = 0.85
)

# 5. Agregar la cuadrícula horizontal punteada gris claro
abline(
  h = pretty(c(0, max_y_bin + 20)),
  col = "gray80",
  lty = 2
)

# 6. Repintar las barras de colores encima de la cuadrícula
barplot(
  rbind(hi_real_bin_unif, P_Binomial_Final),         
  beside = TRUE,        
  col = c("#B0C4DE", "#2E86C1"),
  add = TRUE,
  axes = FALSE,
  names.arg = rep("", 3) 
)

# 7. Agregar la leyenda en la esquina superior derecha
legend(
  "topright",        
  legend = c("Realidad", "Modelo Binomial"),        
  fill = c("#B0C4DE", "#2E86C1"),        
  bty = "n",        
  cex = 0.8
)

# 8. Agregar el título del eje X y el borde exterior
title(xlab = "Migración neta", line = 5, font.lab = 2)
box()

7.2 Modelo geométrico

esperada_normal_geom <- dgeom(0:1, prob = prob_geom)
esperada_cola_geom <- 1 - pgeom(1, prob = prob_geom)

# Convertimos a porcentaje 
hi_modelo_geom <- c(esperada_normal_geom, esperada_cola_geom) * 100

# Creamos la matriz para comparar 
datos_comparacion_geom <- rbind(
  Realidad = hi_geom,
  Modelo = hi_modelo_geom
)

# Configuración de márgenes ampliada para dar espacio a los intervalos
par(mar = c(7, 5, 4, 2) + 0.1)

# Definir los últimos tres intervalos correspondientes a los datos 4, 5 y 6
etiquetas_ultimos_tres <- c("(75k - 325k]", "(325k - 450k]", "(450k - 582k]")

# Gráfica 
grafica_comp_geom <- barplot(
  datos_comparacion_geom,
  beside = TRUE,
  names.arg = etiquetas_ultimos_tres, 
  col = c("#B0C4DE", "#2E86C1"),
  main = "Gráfica N°3: Distribución porcentual de la migración neta en el \nestudio de la calidad de agua en Europa (1991-2017)",
  ylab = "Probabilidad",
  ylim = c(0, max(datos_comparacion_geom) * 1.35),
  las = 1,          # Rota las etiquetas verticalmente
  cex.names = 0.7
)

# Cuadrícula
abline(
  h = pretty(c(0, max(datos_comparacion_geom))),
  col = "gray80",
  lty = 2
)

# Repintar barras
barplot(
  datos_comparacion_geom,
  beside = TRUE,
  col = c("#B0C4DE", "#2E86C1"),
  add = TRUE,
  axes = FALSE,
  names.arg = rep("", 3)
)

# Leyenda
legend(
  "top",
  legend = c("Realidad", "Modelo geométrico"),
  fill = c("#B0C4DE", "#2E86C1"),
  horiz = TRUE,
  bty = "n",
  inset = c(0, 0),
  cex = 0.9
)

# Título del eje X y borde
title(xlab = "Migración neta", line = 5, font.lab = 2)
box()

8. Test de bondad

8.1 Test pearson (Modelo Binomial)

# ==============================================================================
# TEST DE CORRELACIÓN DE PEARSON - MODELO BINOMIAL
# ==============================================================================

# 1. Preparación de variables (Usando las 3 categorías del modelo binomial)
df_correlacion <- data.frame(
  x = 0:2, 
  ni = ni_moderada_unif
)

# 2. Frecuencia Observada (hi en proporción)
Fo_binom <- df_correlacion$ni / sum(df_correlacion$ni)

# 3. Frecuencia Esperada (Probabilidades del modelo ya calculadas: P_Binomial_Final)
# Dividimos para 100 porque en tu código anterior las multiplicaste por 100
Fe_binom <- P_Binomial_Final / 100

# 4. Cálculo de la Correlación de Pearson
Correlacion_Binomial <- cor(Fo_binom, Fe_binom) * 100

# Mostrar resultado
cat("Correlación de Pearson (Modelo Binomial):", round(Correlacion_Binomial, 2), "%\n")

## Correlación de Pearson (Modelo Binomial): 98.89 %

8.2 Test del chi-cuadrado

# ========================================================
# TEST DE CHI-CUADRADO DE PEARSON (MODELO BINOMIAL)
# ========================================================

# 1. Calcular el estadístico Chi-cuadrado (x2)
# Usamos las frecuencias observadas y esperadas que definimos en el paso anterior
x2_binom <- sum(((Fo_binom - Fe_binom)^2) / Fe_binom)

# 2. Calcular el Valor Crítico (vc)
# Con un nivel de confianza del 95% (alfa = 0.05) 
# y 2 grados de libertad (3 categorías - 1 = 2)
vc_binom <- qchisq(0.95, df = 2)

# ========================================================
# IMPRESIÓN DE RESULTADOS Y VALIDACIÓN
# ========================================================
cat("--- RESULTADOS PRUEBA CHI-CUADRADO ---\n")

## --- RESULTADOS PRUEBA CHI-CUADRADO ---

cat("Estadístico Chi-cuadrado calculado (x2):", round(x2_binom, 4), "\n")

## Estadístico Chi-cuadrado calculado (x2): 0.0141

cat("Valor crítico de la tabla (vc):", round(vc_binom, 4), "\n")

## Valor crítico de la tabla (vc): 5.9915

# Si x2 < vc, el modelo APRUEBA (las diferencias no son significativas)
aprobado <- x2_binom < vc_binom
cat("¿El modelo binomial aprueba el test?:", aprobado, "\n")

## ¿El modelo binomial aprueba el test?: TRUE

8.3 Test pearson (Modelo Geométrico)

# ==============================================================================
# 8. TEST DE CORRELACIÓN DE PEARSON (MODELO GEOMÉTRICO)
# ==============================================================================

# Rescatamos las probabilidades teóricas calculadas locales (decimales de las 3 categorías)
P_teorica_geom <- c(esperada_normal_geom, esperada_cola_geom)

# Para Pearson usamos la estructura de frecuencias absolutas del tramo alto (3 categorías)
fo_pearson_geom <- ni_geom
fe_pearson_geom <- N_geom * P_teorica_geom

# Calculamos el Coeficiente de Correlación de Pearson
Coef_Pearson_Geom <- cor(fo_pearson_geom, fe_pearson_geom) * 100

# Mostramos el resultado de Pearson
cat("Coeficiente de Pearson (%):", round(Coef_Pearson_Geom, 2), "\n")

## Coeficiente de Pearson (%): 97.94

8.4 Test del chi-cuadrado

# ==============================================================================
# 9. TEST DE CHI-CUADRADO (MODELO GEOMÉTRICO - MIGRACIÓN ALTA)
# ==============================================================================

# Total de datos del tramo truncado
N_chi <- sum(ni_geom)

# Frecuencia relativa observada (porcentajes hi_geom expresados en proporción decimal)
fo <- hi_geom / 100

# Número de intervalos (en este caso, 3 categorías)
k <- length(fo)

# Probabilidades teóricas esperadas (ya calculadas en decimales en el Paso 6)
fe <- P_teorica_geom

# Chi-cuadrado calculado con frecuencias relativas
Chi_Calculado <- sum((fo - fe)^2 / fe)

# Grados de libertad (k - 1)
gl <- k - 1

# Valor crítico (alfa = 0.05)
Chi_Critico <- qchisq(0.95, df = gl)

# Resultados
cat("\nChi Calculado:", round(Chi_Calculado, 4), "\n")

## 
## Chi Calculado: 0.0559

cat("Chi Crítico:", round(Chi_Critico, 4), "\n")

## Chi Crítico: 5.9915

# Decisión
if (Chi_Calculado < Chi_Critico) {
  print("Evalua H0: El modelo geométrico es adecuado.")
} else {
  print("Se rechaza H0: El modelo geométrico no es adecuado.")
}

## [1] "Evalua H0: El modelo geométrico es adecuado."

9. Cálculo de probabilidades

1.¿Cuál es la probabilidad de que la migración neta en los cuerpos de agua de Europa se sitúe por debajo del 50% de su capacidad total?

# ==========================
# PREGUNTA DE PROBABILIDAD
# ==========================

# Cálculo de probabilidad combinada ponderada
prob_rango <- (pbinom(1, size = 2, prob = prob_p_bin) * (total_n_bin_unif / (total_n_bin_unif + N_geom))) +
              (pgeom(1, prob = prob_geom) * (N_geom / (total_n_bin_unif + N_geom)))

cat("Probabilidad de estar bajo el 50% de capacidad:", round(prob_rango * 100, 2), "%")

## Probabilidad de estar bajo el 50% de capacidad: 92.11 %

2.¿Qué porcentaje de la muestra total de cuerpos de agua en Europa reporta una migración neta dentro del 40% y 60%?

# ======================
# PREGUNTA DE CANTIDAD
# ======================

# Cálculo del porcentaje ponderado general
porcentaje_general <- ((dbinom(1, size = 2, prob = prob_p_bin) * total_n_bin_unif) + 
                       (dgeom(0, prob = prob_geom) * N_geom)) / (total_n_bin_unif + N_geom)

# Comparativa de rango
cat("Porcentaje total:", round(porcentaje_general * 100, 2), "%")

## Porcentaje total: 72.02 %

10. Intervalo de confianza

# ==============================================================================
# 10. INTERVALO DE CONFIANZA
# ==============================================================================

# Calculamos la media de la migración
media_migracion <- mean(Migraciones)

# Calculamos la desviación estándar
desviacion_migracion <- sd(Migraciones)

# Número de observaciones
n_migracion <- length(Migraciones)

# Nivel de confianza del 95% (Z = 1.96)
error_migracion <- 1.96 * (desviacion_migracion / sqrt(n_migracion))

# Límites del intervalo de confianza (redondeado a entero por ser habitantes)
limite_inferior_mig <- round(media_migracion - error_migracion, 0)
limite_superior_mig <- round(media_migracion + error_migracion, 0)

# Creamos la tabla con el formato de intervalo
tabla_intervalo_mig <- data.frame(
  Intervalo = paste0(
    "P [",
    format(limite_inferior_mig, big.mark = ","),
    " < \u03bc < ",
    format(limite_superior_mig, big.mark = ","),
    "] = 95%"
  )
)

# Presentación de la tabla con formato elegante (gt) alineado a la UCE
library(gt)
library(dplyr)

tabla_intervalo_mig %>%
  gt() %>%
  tab_header(
    title = md("*Tabla Nro. 2*"),
    subtitle = md("**Intervalo de confianza de la migración neta en el estudio 
                  de la calidad de agua en Europa (1991-2017)**")
  ) %>%
  tab_source_note(
    source_note = md(
      "Autor : Grupo 3"
    )
  ) %>%
  tab_options(
    table.border.top.color = "black",
    table.border.bottom.color = "black",
    table.border.top.style = "solid",
    table.border.bottom.style = "solid",
    column_labels.border.top.color = "black",
    column_labels.border.bottom.color = "black",
    column_labels.border.bottom.width = px(2),
    row.striping.include_table_body = TRUE,
    heading.border.bottom.color = "black",
    heading.border.bottom.width = px(2),
    table_body.hlines.color = "gray",
    table_body.border.bottom.color = "black",
    table.border.left.color = "black",
    table.border.left.style = "solid",
    table.border.left.width = px(1),
    table.border.right.color = "black",
    table.border.right.style = "solid",
    table.border.right.width = px(1)
  )

Intervalo
Tabla Nro. 2
Intervalo de confianza de la migración neta en el estudio de la calidad de agua en Europa (1991-2017)
P [112,196 < μ < 116,217] = 95%
Autor : Grupo 3

11. Conclusión

La migración neta en la calidad de agua en Europa se ajusta a un modelo integrado: Binomial para el tramo de baja magnitud y Geométrico para el tramo de alta magnitud. Con un 95% de confianza, se determina que la media poblacional del flujo migratorio se encuentra en el intervalo de 112.196 a 116.217 unidades. Asimismo, los test de bondad de ajuste ratifican que ambos modelos se ajustan adecuadamente a la naturaleza de los datos de la variable.

Migración Neta: Modelo binomial y geometrico

Universidad Central del Ecuador

06/06/2026