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 porque permiten analizar si un aumento en los residuos verdes se relaciona con una disminución en el porcentaje de plástico.Para mejorar la visualización, se aplicará una transformación logarítmica únicamente sobre la variable dependiente (Y).
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)
x <- datos_modelo$composition_yard_garden_green_waste_percent
# Variable dependiente transformada (Logaritmo en Y)
y <- datos_modelo$composition_plastic_percent
log_y <- log(y)4. 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 = x,
Plastico = y,
Log_Plastico = log_y
)
tabla_gt <- gt(tabla_resumen) %>%
tab_header(
title = "Tabla 1. Extracto de los pares de valores observados y transformación logarítmica de plástico"
) %>%
fmt_number(
columns = c(Residuos_Verdes, Plastico, Log_Plastico),
decimals = 2
) %>%
cols_label(
Observacion = "Observación",
Residuos_Verdes = "(X) Residuos Verdes (%)",
Plastico = "(Y) Plástico (%)",
Log_Plastico = "Log(Y) Plástico Transformado"
) %>%
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 los pares de valores observados y transformación logarítmica de plástico | |||
| Observación | (X) Residuos Verdes (%) | (Y) Plástico (%) | Log(Y) Plástico Transformado |
|---|---|---|---|
5.Gráfica de Dispersión
# ------------------------------------------------------------------------------
# 5. GRÁFICA DE DISPERSIÓN
# ------------------------------------------------------------------------------
plot(
x,
log_y,
main = "Gráfica No. 1. Diagrama de dispersión (Escala Semilog)\nentre Residuos Verdes y Log(Plástico)",
xlab = "Residuos verdes (%)",
ylab = "Log(Plástico %)",
pch = 16,
col = rgb(135, 206, 235, 180, maxColorValue = 255), # Opacidad ajustada
cex = 1.2, # Puntos ligeramente más grandes para mejor visualización
xlim = c(0, max(x)*1.05),
ylim = c(min(log_y)*0.9, max(log_y)*1.05)
)
## COMENTARIO:
# Al aplicar la transformación logarítmica únicamente en el eje Y (Plástico),
# se estabiliza la dispersión vertical de los datos, permitiendo visualizar
# una clara tendencia decreciente no lineal.6. Conjetura
#==============================================================================
# 4. 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 (Log Y) no se comporta de manera lineal,
# sino que sigue una tendencia polinómica de tercer grado (cúbica). Se asume que
# un incremento inicial de residuos orgánicos desplaza la presencia de plásticos,
# seguido por una meseta de estabilidad intermedia, para finalmente mostrar
# una reducción acelerada en niveles máximos de composición verde.7. Cálculo de parámetros
# Ajustamos el modelo de grado 3: Log(Y) = b0 + b1*X + b2*X^2 + b3*X^3
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]
# Impresión limpia uno por uno en la consola
print(paste("Intercepto (beta0):", round(beta0, 4)))## [1] "Intercepto (beta0): 3.6654"print(paste("Coeficiente X (beta1):", round(beta1, 4)))## [1] "Coeficiente X (beta1): -0.2986"print(paste("Coeficiente X^2 (beta2):", round(beta2, 4)))## [1] "Coeficiente X^2 (beta2): 0.021"print(paste("Coeficiente X^3 (beta3):", round(beta3, 4)))## [1] "Coeficiente X^3 (beta3): -5e-04"8. Comparación de la realidad con el modelo
# ==============================================================================
# GRÁFICA NO. 2: AJUSTE DEL MODELO POLINÓMICO CÚBICO
# ==============================================================================
# 1. Dibujamos el plano cartesiano con tus puntos originales intactos
plot(
x,
log_y,
main = "Gráfica No. 2. Ajuste del Modelo Polinómico Cúbico (Log en Y)\nentre Residuos Verdes y Plástico",
xlab = "Residuos verdes (%)",
ylab = "Log(Plástico %)",
pch = 16,
col = rgb(135, 206, 235, 180, maxColorValue = 255),
cex = 1.3,
xlim = c(0, 35), # Mantenemos la escala horizontal fija original
ylim = c(0, 3.5) # Mantenemos la escala vertical fija original
)
# 2. Creamos una secuencia matemática de 1000 puntos continuos para la curva suave
x_curva <- seq(min(x), max(x), length.out = 1000)
# 3. El TRUCO: Creamos el newdata usando exactamente el nombre de la variable "x"
dataframe_prediccion <- data.frame(x = x_curva)
log_y_curva <- predict(modelo_definitivo, newdata = dataframe_prediccion)
# 4. Trazamos la línea del modelo en color rojo sobre la nube completa de puntos
lines(x_curva, log_y_curva, col = "red", lwd = 3)
9. Test de bondad
# =================
# TEST DE BONDAD
# =================
# Calculamos el coeficiente de correlación de Pearson
r_pearson <- cor(x, log_y, method = "pearson")
cat("--- TEST DE BONDAD DEL AJUSTE ---\n")## --- TEST DE BONDAD DEL AJUSTE ---cat("Coeficiente de Correlación de Pearson (r):", round(r_pearson, 4), "\n")## Coeficiente de Correlación de Pearson (r): -0.854110. Restricciones
# Dominio [X] - Porcentaje de Residuos Verdes:
# D = {x ∈ R | 0 < x ≤ 100}
# Dominio [Y] - Porcentaje de Plástico Original:
# 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. Debido a las propiedades de la transformación semilogarítmica empleada, al aplicar la función inversa para regresar a la escala original (Y = exp(Log_Y)), el modelo matemático siempre arrojará valores de porcentaje de plástico (Y) estrictamente positivos (mayores a 0%). 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 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 escala logarítmica
log_plastico_estimado <- predict(modelo_definitivo, newdata = data.frame(x = residuos_verdes))
# Aplicamos exp() para obtener el porcentaje real de plástico original (Y)
plastico_estimado_real <- exp(log_plastico_estimado)
# Extracción de coeficientes con formato limpio para la ecuación
b0 <- format(round(coef(modelo_definitivo)[1], 2), nsmall = 2)
b1 <- format(round(coef(modelo_definitivo)[2], 2), nsmall = 2)
b2 <- format(round(coef(modelo_definitivo)[3], 4), nsmall = 4)
b3 <- format(round(coef(modelo_definitivo)[4], 5), nsmall = 5)
#==============================================================================
# CREAR CURVA POLINÓMICA AJUSTADA (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 (SÓLO LA CURVA)
#==============================================================================
x_min <- 0
x_max <- 35
y_min <- 0
y_max <- 3.5
# 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",
xlab = "Residuos verdes (%)",
ylab = "Log(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 = "purple",
lwd = 2
)
# Líneas guía discontinuas hacia los ejes (usando la coordenada logarítmica)
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.15,
labels = paste0(residuos_verdes, " %"),
col = "red",
font = 2,
cex = 0.8
)
# Mostramos el porcentaje real calculado en la etiqueta del eje Y
text(
x = x_min + 2.8,
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 e incrustada
#--------------------------------------------------------------------------
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
ecuacion_txt <- bquote(Log(Y) == .(b0) + (.(b1))*X + (.(b2))*X^2 + (.(b3))*X^3)
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 logaritmo del porcentaje de plástico existe una relación polinómica de tercer grado representada por el modelo Log(Y) = 3.67 - 0.30X + 0.0210X^2 - 0.00048X^3. El modelo no presenta restricciones dentro del rango observado, mostrando que el plástico disminuye inicialmente, se estabiliza en una meseta intermedia y vuelve a descender notablemente en el extremo superior.