Modelo Polinómico
Universidad Central del Ecuador
2026-06-17
1.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, unionlibrary(gt)
library(htmltools)2.Leer datos
# -------------------------
# Cargar datos
# -------------------------
datos <- read.csv("waterPollution.csv",
sep = ",",
stringsAsFactors = FALSE)3. Selección (causa y efecto)
# ================================
# SELECCIÓN Y SEPARACIÓN
# ================================
# Justificación de las variables:
# Se seleccionaron estas variables para analizar cómo influye la presencia de residuos verdes (X) en la reducción de contaminantes plásticos (Y) en cuerpos de agua. Evaluando una posible relación polinómica.
datos_modelo <- datos %>%
select(
composition_yard_garden_green_waste_percent,
composition_plastic_percent
) %>%
na.omit() %>%
filter(
composition_yard_garden_green_waste_percent > 0,
composition_plastic_percent > 0
)
# Variable independiente
x <- datos_modelo$composition_yard_garden_green_waste_percent
# Variable dependiente
y <- datos_modelo$composition_plastic_percent4. Tabla de pares de valores
4.1 Tamaño muestral
# 1. Cálculo del tamaño muestral de cada variable
n_x <- length(x)
n_y <- length(y)
# 2. Imprimir los tamaños muestrales
cat("Tamaño muestral de X (Residuos Verdes):", n_x, "observaciones.\n")## Tamaño muestral de X (Residuos Verdes): 5047 observaciones.cat("Tamaño muestral de Y (Plástico):", n_y, "observaciones.\n\n")## Tamaño muestral de Y (Plástico): 5047 observaciones.4.2 Extracto de las variables
# ================================
# TABLA DE PARES DE VALORES
# ================================
tabla_resumen <- data.frame(
Observacion = 1:nrow(datos_modelo),
Residuos_Verdes = datos_modelo$composition_yard_garden_green_waste_percent,
Plastico = datos_modelo$composition_plastic_percent
)
tabla_gt <- gt(tabla_resumen) %>%
tab_header(
title = "Tabla 1. Extracto de pares de valores observados de residuos verdes y plástico"
) %>%
fmt_number(
columns = c(Residuos_Verdes, Plastico),
decimals = 2
) %>%
cols_label(
Observacion = "Observación",
Residuos_Verdes = "(X) Residuos Verdes (%)",
Plastico = "(Y) Plástico (%)"
) %>%
cols_align(
align = "center",
columns = everything()
)
browsable(
div(
style = "height:400px; overflow-y:auto; border:1px solid #ddd;",
HTML(as_raw_html(tabla_gt))
)
)| Tabla 1. Extracto de pares de valores observados de residuos verdes y plástico | ||
| Observación | (X) Residuos Verdes (%) | (Y) Plástico (%) |
|---|---|---|
5.Gráfica de Dispersión
5.1 Gráfica de Dispersión Global
# ------------------------------------------------------------------------------
# 5. GRÁFICA DE DISPERSIÓN
# ------------------------------------------------------------------------------
plot(
x,
y,
main = "Gráfica No. 1. Diagrama de dispersión entre Residuos Verdes\ny Plástico en el estudio de la calidad de agua en Europa",
xlab = "Residuos verdes (%)",
ylab = "Plástico (%)",
pch = 16,
col = rgb(135,206,235,120,maxColorValue = 255),
cex = 0.8,
xlim = c(0, max(x)*1.05),
ylim = c(0, max(y)*1.05)
)
## COMENTARIO:
# Aunque la muestra está conformada por 5047 observaciones, el diagrama de dispersión muestra un número reducido de puntos debido a la superposición de observaciones. Esto ocurre porque las variables presentan pocos valores distintos, compartiendo las mismas coordenadas (X,Y).
#Tras analizar la dispersión de los datos, decidimos aplicar una transformación logarítmica de base alta (Log2000) en el eje Y. Con esto se logra comprimir de forma óptima el eje vertical del modelo, reduciendo significativamente la distancia visual de los puntos para mejorar el ajuste gráfico.5.2 Tratamiento de los datos
# ------------------------------------------------------------------------------
# 5.2 TRATAMIENTO DE LOS DATOS
# ------------------------------------------------------------------------------
datos_modelo <- datos %>%
select(
composition_yard_garden_green_waste_percent,
composition_plastic_percent
) %>%
na.omit() %>%
filter(
composition_yard_garden_green_waste_percent > 0,
composition_plastic_percent > 0
)
# Variable independiente (Escala original completa)
x <- datos_modelo$composition_yard_garden_green_waste_percent
# Variable dependiente transformada (Logaritmo en Base 2000 en Y)
y <- datos_modelo$composition_plastic_percent
log_y <- log(y, base = 2000)5.3 Gráfica de dispersión aplicado el logaritmo
# ------------------------------------------------------------------------------
# 5.3 GRÁFICA CON EL LOGARITMO (BASE 2000)
# ------------------------------------------------------------------------------
plot(
x,
log_y,
main = "Gráfica No. 1. Diagrama de dispersión logarítmica \nentre Residuos Verdes y Log2000(Plástico)",
xlab = "Residuos verdes (%)",
ylab = "Log2000(Plástico %)",
pch = 16,
col = rgb(135, 206, 235, 180, maxColorValue = 255),
cex = 1.2,
xlim = c(0, max(x)*1.05),
ylim = c(0, 0.6) # Acotamos el límite vertical para comprimir el espacio visual
)
6. Conjetura
#==============================================================================
# 6. CONJETURA (Planteamiento Teórico)
#==============================================================================
# Tras analizar el comportamiento inicial de la dispersión, se plantea como
# conjetura teórica que la relación entre el porcentaje de residuos verdes (X)
# y el logaritmo del porcentaje de plástico en base 2000 (Log2000 Y) no se comporta
# de manera lineal, sino que sigue una tendencia polinómica de tercer grado (cúbica). 7. Cálculo de parámetros
# ============================
# # 7. Cálculo de parámetros
# ============================
# Ajustamos el modelo de grado 3 usando la nueva escala log_y (base 2000)
modelo_definitivo <- lm(log_y ~ x + I(x^2) + I(x^3))
# Extracción individual de coeficientes (Betas)
beta0 <- modelo_definitivo$coefficients[1]
beta1 <- modelo_definitivo$coefficients[2]
beta2 <- modelo_definitivo$coefficients[3]
beta3 <- modelo_definitivo$coefficients[4]
# Forzamos a R a no usar notación científica y mostrar los decimales reales
print(paste("Intercepto (beta0):", format(round(beta0, 4), nsmall = 4)))## [1] "Intercepto (beta0): 0.4822"print(paste("Coeficiente X (beta1):", format(round(beta1, 4), nsmall = 4)))## [1] "Coeficiente X (beta1): -0.0393"print(paste("Coeficiente X^2 (beta2):", format(round(beta2, 5), nsmall = 5)))## [1] "Coeficiente X^2 (beta2): 0.00277"print(paste("Coeficiente X^3 (beta3):", format(round(beta3, 6), nsmall = 6)))## [1] "Coeficiente X^3 (beta3): -6.3e-05"8. Comparación de la realidad con el modelo
# ==============================================================================
# # 8. Comparación de la realidad con el modelo
# ==============================================================================
plot(
x,
log_y,
main = "Gráfica No. 2. Regresión del Modelo Polinómico Cúbico (Log2000 en Y)\nentre Residuos Verdes y Plástico",
xlab = "Residuos verdes (%)",
ylab = "Log2000(Plástico %)",
pch = 16,
col = rgb(135, 206, 235, 180, maxColorValue = 255),
cex = 1.3,
xlim = c(0, 35),
ylim = c(0, 0.6) #límite vertical fijo para mantener el efecto de cercanía a la curva
)
# Secuencia matemática de 1000 puntos continuos para la curva suave
x_curva <- seq(min(x), max(x), length.out = 1000)
# Predicción utilizando el modelo ajustado
dataframe_prediccion <- data.frame(x = x_curva)
log_y_curva <- predict(modelo_definitivo, newdata = dataframe_prediccion)
# Trazamos la curva del modelo
lines(x_curva, log_y_curva, col = "red", lwd = 3)
9. Test de bondad
# ==============================================================================
# # 9. Test de bondad (Coeficiente de Correlación de Pearson)
# ==============================================================================
# Calculamos el coeficiente de correlación de Pearson entre X y el Log2000(Y)
r_pearson <- cor(x, log_y, method = "pearson")
# Imprimir el resultado de forma limpia en la consola
cat("--- TEST DE BONDAD DEL AJUSTE (BASE 2000) ---\n")## --- TEST DE BONDAD DEL AJUSTE (BASE 2000) ---cat("Coeficiente de Correlación de Pearson (r):", round(r_pearson, 4), "\n")## Coeficiente de Correlación de Pearson (r): -0.854110. Restricciones
# ==============================================================================
# # 10. Restricciones del Modelo
# ==============================================================================
# Dominio [X] - Porcentaje de Residuos Verdes:
# D_x = {x ∈ R | 0 < x ≤ 100}
# Dominio [Y] - Porcentaje de Plástico:
# D_y = {y ∈ R | 0 < y ≤ 100}
# ¿Existe algún valor en el dominio de X que, sustituido en el modelo matemático, genere un valor en Y fuera de su dominio?
# RESPUESTA:
#No Debido a las propiedades algebraicas de la transformación empleada, al aplicar la función inversa para regresar a la escala original (Y = 2000^log_y), el modelo nunca arrojará valores menores o iguales a cero. Cualquier exponente real sobre la base 2000 dará como resultado un porcentaje de plástico estrictamente positivo (Y > 0%).11. Estimaciones
# ==============================================================================
# # 11. Estimaciones del Modelo (Base 2000)
# ==============================================================================
### Pregunta de investigación:
# ¿Cuál es el porcentaje estimado de residuos plásticos en los cuerpos de agua cuando
# el porcentaje de residuos verdes es del 10 %, según el modelo polinómico de tercer grado obtenido?
#--------------------------------------------------------------------------
# Valor de X para realizar la estimación
#--------------------------------------------------------------------------
residuos_verdes <- 10
#--------------------------------------------------------------------------
# Estimación exacta usando la función predict
#--------------------------------------------------------------------------
# Predict nos devuelve el valor en la nueva escala logarítmica (Base 2000)
log_plastico_estimado <- predict(modelo_definitivo, newdata = data.frame(x = residuos_verdes))
# ¡CRUCIAL!: Aplicamos la base 2000 para obtener el porcentaje real de plástico original (Y)
plastico_estimado_real <- 2000^(log_plastico_estimado)
# Extracción de coeficientes con formato limpio para la ecuación de la leyenda
b0 <- format(round(coef(modelo_definitivo)[1], 4), nsmall = 4)
b1 <- format(round(coef(modelo_definitivo)[2], 4), nsmall = 4)
b2 <- format(round(coef(modelo_definitivo)[3], 5), nsmall = 5)
b3 <- format(round(coef(modelo_definitivo)[4], 6), nsmall = 6)
#==============================================================================
# CREAR CURVA POLINÓMICA AJUSTADA CONTINUA (GRADO 3)
#==============================================================================
x_curva <- seq(
min(x, na.rm = TRUE) - 1,
max(x, na.rm = TRUE) + 1,
length.out = 1000
)
log_y_curva <- predict(modelo_definitivo, newdata = data.frame(x = x_curva))
#==============================================================================
# GRÁFICA No. 3: MODELO POLINÓMICO CÚBICO CON ESTIMACIÓN (COMPRIMIDO EN BASE 2000)
#==============================================================================
x_min <- 0
x_max <- 35
# Mantenemos los mismos límites fijos de Y (0 a 1.2) para conservar el efecto visual de cercanía
y_min <- 0
y_max <- 0.6
# Creamos el lienzo base vacío
plot(
x,
log_y,
type = "n",
main = "Gráfica No. 3: Modelo Polinómico Cúbico con Estimación (Base 2000)",
xlab = "Residuos verdes (%)",
ylab = "Log2000(Plástico %)",
xlim = c(x_min, x_max),
ylim = c(y_min, y_max),
xaxs = "i",
yaxs = "i"
)
# Dibujar la curva de tercer grado (Cúbica) en color púrpura
lines(
x_curva,
log_y_curva,
col = "blue",
lwd = 2
)
# Líneas guía discontinuas hacia los ejes (usando la coordenada logarítmica corregida)
segments(
x0 = residuos_verdes,
y0 = y_min,
x1 = residuos_verdes,
y1 = log_plastico_estimado,
col = "gray60",
lty = 2
)
segments(
x0 = x_min,
y0 = log_plastico_estimado,
x1 = residuos_verdes,
y1 = log_plastico_estimado,
col = "gray60",
lty = 2
)
# Punto de la estimación en color rojo
points(
x = residuos_verdes,
y = log_plastico_estimado,
col = "red",
pch = 18,
cex = 1.6
)
# Etiquetas en los ejes para identificar los valores exactos
text(
x = residuos_verdes,
y = y_min + 0.05,
labels = paste0(residuos_verdes, " %"),
col = "red",
font = 2,
cex = 0.8
)
# Mostramos el porcentaje real calculado (Y) en la etiqueta del eje Y
text(
x = x_min + 4,
y = log_plastico_estimado,
labels = paste0(round(plastico_estimado_real, 2), " % (Real)"),
col = "red",
font = 2,
pos = 3,
cex = 0.8
)
#--------------------------------------------------------------------------
# Leyenda explicativa con la ecuación matemática real ajustada a Base 2000
#--------------------------------------------------------------------------
txt1 <- paste0("Estimación: X = ", residuos_verdes, "% → Y = ", round(plastico_estimado_real, 2), "%")
# Construcción de la ecuación en escala Logarítmica para grado 3 (Base 2000)
ecuacion_txt <- bquote(Log[2000](Y) == .(b0) + (.(b1))*X + (.(b2))*X^2 + (.(b3))*X^3)
legend(
"topright",
legend = as.expression(c(txt1, ecuacion_txt)),
col = c("red", "blue"),
pch = c(18, NA),
lty = c(0, 1),
lwd = c(NA, 2),
bty = "o",
bg = "white",
cex = 0.7
)
12. Conclusión
Entre el porcentaje de residuos verdes y el logaritmo en base 2000 del porcentaje de plástico existe una relación polinómica de tercer grado representada por el modelo Log2000(Y) = 0.4822 - 0.0393X + 0.00277X^2 - 0.000063X^3. El modelo no presenta restricciones dentro del dominio observado, mostrando que el plástico disminuye inicialmente, se estabiliza en una meseta intermedia y vuelve a descender notablemente en el extremo superior, logrando comprimir de forma óptima la dispersión de los datos sin excluir ninguna observación.