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)## Warning: package 'htmltools' was built under R version 4.6.12.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 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. 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).6. Conjetura
# El diagrama de dispersión muestra un comportamiento no lineal que decae al inicio, se estabiliza en rangos intermedios (10 % a 20 %) y vuelve a descender al final. Debido a esta trayectoria curva y multifacética, los modelos simples (lineal o exponencial) no logran describir fielmente los datos.
# Se plantea la conjetura de que la relación se modela de forma óptima mediante una regresión
# polinómica de cuarto grado. Este modelo ofrece la flexibilidad matemática necesaria para ajustarse a la tendencia real, suavizar el ruido de la muestra y describir con precisión la sustitución material en los cuerpos de agua sin generar un sobreajuste inestable.7. Cálculo de parámetros
# Ajuste del modelo polinómico de grado 4: Y = b0 + b1*X + b2*X^2 + b3*X^3 + b4*X^4
modelo_poli <- lm(y ~ x + I(x^2) + I(x^3) + I(x^4))
# Extracción de coeficientes
beta0 <- modelo_poli$coefficients[1]
beta1 <- modelo_poli$coefficients[2]
beta2 <- modelo_poli$coefficients[3]
beta3 <- modelo_poli$coefficients[4]
beta4 <- modelo_poli$coefficients[5]
print(paste("Intercepto (beta0):", round(beta0, 4)))## [1] "Intercepto (beta0): 21.9054"print(paste("Coeficiente X (beta1):", round(beta1, 4)))## [1] "Coeficiente X (beta1): -0.0231"print(paste("Coeficiente X^2 (beta2):", round(beta2, 4)))## [1] "Coeficiente X^2 (beta2): -0.3048"print(paste("Coeficiente X^3 (beta3):", round(beta3, 4)))## [1] "Coeficiente X^3 (beta3): 0.0234"print(paste("Coeficiente X^4 (beta4):", round(beta4, 4)))## [1] "Coeficiente X^4 (beta4): -5e-04"8. Comparación de la realidad con el modelo
plot(x, y,
main = "Gráfica No 2: Regresión Polinómica entre Residuos\nVerdes y Plástico en el estudio de la calidad de agua en Europa",
xlab = "Residuos verdes (%)",
ylab = "Plástico (%)",
col = "#87CEEB90",
pch = 16,
xlim = c(0, max(x) * 1.05),
ylim = c(0, max(y) * 1.05))
# Curva ajustada de grado 4
x_curva <- seq(min(x), max(x), length.out = 1000)
y_curva <- predict(modelo_poli, newdata = data.frame(x = x_curva))
lines(x_curva, y_curva, col = "purple", lwd = 3)
9. Test de bondad
# =================
# TEST DE BONDAD
# =================
# Cálculo del coeficiente de correlación de Pearson (r)
r <- cor(x, y) * 100
print(paste("Coeficiente de Correlación de Pearson (r):", round(r, 2), "%"))## [1] "Coeficiente de Correlación de Pearson (r): -88.98 %"10. Restricciones
# Dominio [X]:
# D = {x ∈ R | 0 < x ≤ 100}
# Dominio [Y]:
# D = {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?
# NO. No existe ninguna restricción matemática formal en el dominio de la función original. Sin embargo, dado que el modelo es un polinomio de cuarto grado, su aplicación práctica debe limitarse estrictamente al rango de los datos reales observados (de 0 % a 31 % de residuos verdes) para evitar que la curva extrapole valores negativos de plástico, lo cual sería físicamente imposible.11. Estimaciones
### Pregunta
# ¿Cuál es el porcentaje estimado de residuos plásticos en los cuerpos de agua de Europa cuando
# el porcentaje de residuos verdes es del 10 %, según el modelo polinómico de cuarto grado obtenido?
#--------------------------------------------------------------------------
# Valor de X para realizar la estimación
#--------------------------------------------------------------------------
residuos_verdes <- 10
#--------------------------------------------------------------------------
# Estimación exacta usando la función predict
#--------------------------------------------------------------------------
plastico_estimado <- predict(modelo_poli, newdata = data.frame(x = residuos_verdes))
# Extracción de coeficientes con formato limpio para la ecuación
b0 <- format(round(coef(modelo_poli)[1], 2), nsmall = 2)
b1 <- format(round(coef(modelo_poli)[2], 2), nsmall = 2)
b2 <- format(round(coef(modelo_poli)[3], 4), nsmall = 4)
b3 <- format(round(coef(modelo_poli)[4], 5), nsmall = 5)
b4 <- format(round(coef(modelo_poli)[5], 6), nsmall = 6)
#==============================================================================
# CREAR CURVA POLINÓMICA AJUSTADA (GRADO 4)
#==============================================================================
x_curva <- seq(
min(x, na.rm = TRUE) - 1,
max(x, na.rm = TRUE) + 1,
length.out = 1000
)
y_curva <- predict(modelo_poli, newdata = data.frame(x = x_curva))
#==============================================================================
# GRÁFICA No. 3: MODELO POLINÓMICO CON ESTIMACIÓN
#==============================================================================
x_min <- min(x, na.rm = TRUE) - 1
x_max <- max(x, na.rm = TRUE) + 1
y_min <- 0
y_max <- max(y, na.rm = TRUE) + 2
plot(
x,
y,
type = "n",
main = "Gráfica No. 3: Modelo Polinómico con Estimación",
xlab = "Residuos verdes (%)",
ylab = "Plástico (%)",
xlim = c(x_min, x_max),
ylim = c(y_min, y_max),
xaxs = "r",
yaxs = "r"
)
# Dibujar la curva de cuarto grado
lines(
x_curva,
y_curva,
col = "purple",
lwd = 2
)
# Líneas guía discontinuas hacia los ejes
segments(
x0 = residuos_verdes,
y0 = y_min,
x1 = residuos_verdes,
y1 = plastico_estimado,
col = "gray60",
lty = 2
)
segments(
x0 = x_min,
y0 = plastico_estimado,
x1 = residuos_verdes,
y1 = plastico_estimado,
col = "gray60",
lty = 2
)
# Punto de la estimación en color rojo
points(
residuve_verdes <- residuos_verdes,
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.5,
labels = paste0(residuos_verdes, " %"),
col = "red",
font = 2,
cex = 0.8
)
text(
x = x_min + 1.2,
y = plastico_estimado,
labels = paste0(round(plastico_estimado, 2), " %"),
col = "red",
font = 2,
pos = 3,
cex = 0.8
)
#--------------------------------------------------------------------------
# Leyenda explicativa con la ecuación matemática real e incrustada
#--------------------------------------------------------------------------
txt1 <- paste0("Estimación: X = ", residuos_verdes, "% → Y = ", round(plastico_estimado, 2), "%")
# Construcción de la ecuación
ecuacion_txt <- bquote(Y == .(b0) + (.(b1))*X + (.(b2))*X^2 + (.(b3))*X^3 + (.(b4))*X^4)
legend(
"topright",
legend = as.expression(c(txt1, ecuacion_txt)),
col = c("red", "purple"),
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 porcentaje de plástico existe una relación de tipo polinómica de cuarto grado, representada por el modelo Y = 21.91 - 0.02X - 0.3048X^2 + 0.02335X^3 - 0.000461X^4, siendo Y = Plástico (%) y X = Residuos verdes (%). El modelo no presenta restricciones, indicando que el porcentaje de plástico decae marcadamente con los primeros incrementos de residuos verdes, experimenta una leve zona de estabilización intermedia y vuelve a descender en el extremo superior.