Inicio Datos Tabla Dispersión Modelo Curva Evaluación Restricciones Pronóstico Conclusión

ANÁLISIS ESTADÍSTICO DE DESLIZAMIENTOS

Modelo 3: Regresión Potencial

Este modelo evalúa una relación de tipo potencial entre la precipitación acumulada en 7 días y el índice de susceptibilidad a deslizamientos.

MODELO 3: REGRESIÓN POTENCIAL

1. LIBRERÍAS Y CARGA DEL DATASET

library(readxl)
library(ggplot2)
library(knitr)

datos <- read_excel("dataset_landslides.xlsx", sheet = "Dataset_landslides")

datos <- as.data.frame(datos)

options(scipen = 999)

resumen_dataset <- data.frame(
  Elemento = c(
    "Archivo utilizado",
    "Hoja utilizada",
    "Número de filas",
    "Número de columnas",
    "Variable independiente X",
    "Variable dependiente Y"
  ),
  Descripcion = c(
    "dataset_landslides.xlsx",
    "Dataset_landslides",
    nrow(datos),
    ncol(datos),
    "Precipitación acumulada en 7 días",
    "Índice de susceptibilidad a deslizamientos"
  )
)

knitr::kable(
  resumen_dataset,
  caption = "Resumen inicial del dataset"
)
Resumen inicial del dataset
Elemento Descripcion
Archivo utilizado dataset_landslides.xlsx
Hoja utilizada Dataset_landslides
Número de filas 11033
Número de columnas 25
Variable independiente X Precipitación acumulada en 7 días
Variable dependiente Y Índice de susceptibilidad a deslizamientos

2. SELECCIÓN DE VARIABLES

limpiar_numerico <- function(variable) {
  variable <- as.character(variable)
  variable <- gsub(",", ".", variable)
  as.numeric(variable)
}

datos_regresion <- data.frame(
  precipitation_7d_mm = limpiar_numerico(datos$precipitation_7d_mm),
  susceptibility_index = limpiar_numerico(datos$susceptibility_index)
)

datos_regresion <- datos_regresion[
  is.finite(datos_regresion$precipitation_7d_mm) &
    is.finite(datos_regresion$susceptibility_index) &
    datos_regresion$precipitation_7d_mm > 0 &
    datos_regresion$susceptibility_index > 0,
]

x <- datos_regresion$precipitation_7d_mm
y <- datos_regresion$susceptibility_index

tabla_variables <- data.frame(
  Variable = c("X", "Y"),
  Nombre_en_dataset = c(
    "precipitation_7d_mm",
    "susceptibility_index"
  ),
  Descripcion = c(
    "Precipitación acumulada en 7 días",
    "Índice de susceptibilidad a deslizamientos"
  ),
  Unidad = c("mm", "Índice")
)

knitr::kable(
  tabla_variables,
  caption = "Variables seleccionadas para el modelo potencial"
)
Variables seleccionadas para el modelo potencial
Variable Nombre_en_dataset Descripcion Unidad
X precipitation_7d_mm Precipitación acumulada en 7 días mm
Y susceptibility_index Índice de susceptibilidad a deslizamientos Índice

3. TABLA DE PARES DE VALORES

tabla_pares <- data.frame(
  Precipitacion_7_dias_mm = x,
  Indice_susceptibilidad = y
)

knitr::kable(
  head(tabla_pares, 10),
  digits = 4,
  caption = "Primeros diez pares de valores utilizados en el modelo potencial"
)
Primeros diez pares de valores utilizados en el modelo potencial
Precipitacion_7_dias_mm Indice_susceptibilidad
60.21 83.27
115.77 93.48
47.14 87.15
52.52 74.52
12.51 37.58
84.97 89.74
121.28 93.52
83.39 80.28
93.87 81.31
105.27 89.49 
resumen_variables <- data.frame(
  Variable = c("Precipitación acumulada 7 días", "Índice de susceptibilidad"),
  Minimo = c(min(x), min(y)),
  Media = c(mean(x), mean(y)),
  Mediana = c(median(x), median(y)),
  Maximo = c(max(x), max(y))
)

knitr::kable(
  resumen_variables,
  digits = 2,
  caption = "Resumen estadístico de las variables"
)
Resumen estadístico de las variables
Variable Minimo Media Mediana Maximo
Precipitación acumulada 7 días 0.50 71.91 62.74 507.07
Índice de susceptibilidad 13.62 75.39 78.91 99.00

4. GRÁFICA ORIGINAL: NUBE DE PUNTOS

ggplot(
  datos_regresion,
  aes(
    x = precipitation_7d_mm,
    y = susceptibility_index
  )
) +
  geom_point(
    color = "blue",
    alpha = 0.30,
    size = 1.7
  ) +
  labs(
    title = "REGRESIÓN POTENCIAL",
    subtitle = "Nube de puntos entre precipitación acumulada y susceptibilidad",
    x = "Precipitación acumulada en 7 días (mm)",
    y = "Índice de susceptibilidad a deslizamientos"
  ) +
  theme_bw(base_size = 15) +
  theme(
    plot.title = element_text(
      hjust = 0.5,
      face = "bold",
      size = 26,
      color = "#0B3C5D"
    ),
    plot.subtitle = element_text(
      hjust = 0.5,
      size = 13,
      color = "#444444"
    ),
    axis.title = element_text(
      face = "bold",
      size = 13
    ),
    axis.text = element_text(
      size = 11
    ),
    panel.border = element_rect(
      color = "gray35",
      fill = NA,
      linewidth = 1
    ),
    panel.grid.major = element_line(
      color = "gray88"
    ),
    panel.grid.minor = element_blank(),
    plot.background = element_rect(
      fill = "white",
      color = NA
    ),
    panel.background = element_rect(
      fill = "white",
      color = NA
    )
  )

5. CONJETURA Y ESTRUCTURA MATEMÁTICA

Conjetura del modelo

A medida que aumenta la precipitación acumulada en 7 días, el índice de susceptibilidad a deslizamientos tiende a incrementarse con una forma no lineal, por lo que se propone un modelo de tipo potencial.

La estructura matemática del modelo potencial es:

\[ \hat{y} = ax^{b} \]

Donde:

  • \(\hat{y}\) = índice de susceptibilidad estimado.
  • \(x\) = precipitación acumulada en 7 días.
  • \(a\) = coeficiente inicial del modelo.
  • \(b\) = exponente o parámetro de crecimiento potencial.

6. CÁLCULO DE PARÁMETROS DEL MODELO

modelo_inicial <- lm(
  log(susceptibility_index) ~ log(precipitation_7d_mm),
  data = datos_regresion
)

a_inicio <- exp(coef(modelo_inicial)[1])
b_inicio <- coef(modelo_inicial)[2]

modelo_potencial <- nls(
  susceptibility_index ~ a * precipitation_7d_mm^b,
  data = datos_regresion,
  start = list(
    a = a_inicio,
    b = b_inicio
  ),
  control = nls.control(
    maxiter = 500,
    warnOnly = TRUE
  )
)

parametros <- coef(modelo_potencial)

a_potencial <- as.numeric(parametros["a"])
b_potencial <- as.numeric(parametros["b"])

y_estimado <- predict(modelo_potencial)

sse <- sum((y - y_estimado)^2)
sst <- sum((y - mean(y))^2)
r_cuadrado <- 1 - (sse / sst)

rmse <- sqrt(mean((y - y_estimado)^2))

tabla_modelo <- data.frame(
  Parametro = c("a", "b", "R²", "RMSE"),
  Valor = c(a_potencial, b_potencial, r_cuadrado, rmse),
  Interpretacion = c(
    "Coeficiente inicial del modelo potencial",
    "Exponente o parámetro de crecimiento potencial",
    "Proporción de variabilidad explicada por el modelo en la escala original",
    "Error promedio aproximado del modelo"
  )
)

knitr::kable(
  tabla_modelo,
  digits = 4,
  caption = "Parámetros principales del modelo potencial"
)
Parámetros principales del modelo potencial
Parametro Valor Interpretacion
a 24.8956 Coeficiente inicial del modelo potencial
b 0.2690 Exponente o parámetro de crecimiento potencial
R² 0.7228 Proporción de variabilidad explicada por el modelo en la escala original
RMSE 8.6181 Error promedio aproximado del modelo

Resultado del modelo potencial

Ecuación potencial

Y = a * xb

Y = 24.9 * x0.269

R² = 0.7228

El modelo explica aproximadamente 72.28% de la variabilidad observada en el índice de susceptibilidad.

RMSE = 8.62 

tabla_coeficientes <- data.frame(
  Parametro = c("a", "b"),
  Valor = c(a_potencial, b_potencial),
  Significado = c(
    "Coeficiente inicial de la curva potencial",
    "Exponente que define la forma de crecimiento de la curva"
  )
)

knitr::kable(
  tabla_coeficientes,
  digits = 4,
  caption = "Coeficientes del modelo potencial directo"
)
Coeficientes del modelo potencial directo
Parametro Valor Significado
a 24.8956 Coeficiente inicial de la curva potencial
b 0.2690 Exponente que define la forma de crecimiento de la curva

7. CURVA POTENCIAL SOBRE LA NUBE DE PUNTOS

x_secuencia <- seq(
  min(x),
  max(x),
  length.out = 300
)

curva_potencial <- data.frame(
  precipitation_7d_mm = x_secuencia,
  susceptibilidad_estimada = a_potencial * x_secuencia^b_potencial
)

ecuacion_texto <- paste0(
  "y = ",
  round(a_potencial, 4),
  "x^",
  round(b_potencial, 4),
  "   |   R² = ",
  round(r_cuadrado, 3)
)

ggplot() +
  geom_point(
    data = datos_regresion,
    aes(
      x = precipitation_7d_mm,
      y = susceptibility_index
    ),
    color = "blue",
    alpha = 0.30,
    size = 1.7
  ) +
  geom_line(
    data = curva_potencial,
    aes(
      x = precipitation_7d_mm,
      y = susceptibilidad_estimada
    ),
    color = "red",
    linewidth = 1.5
  ) +
  labs(
    title = "REGRESIÓN POTENCIAL",
    subtitle = ecuacion_texto,
    x = "Precipitación acumulada en 7 días (mm)",
    y = "Índice de susceptibilidad a deslizamientos"
  ) +
  theme_bw(base_size = 15) +
  theme(
    plot.title = element_text(
      hjust = 0.5,
      face = "bold",
      size = 26,
      color = "#0B3C5D"
    ),
    plot.subtitle = element_text(
      hjust = 0.5,
      face = "bold",
      size = 13,
      color = "#222222"
    ),
    axis.title = element_text(
      face = "bold",
      size = 13
    ),
    axis.text = element_text(
      size = 11
    ),
    panel.border = element_rect(
      color = "gray35",
      fill = NA,
      linewidth = 1
    ),
    panel.grid.major = element_line(
      color = "gray88"
    ),
    panel.grid.minor = element_blank(),
    plot.background = element_rect(
      fill = "white",
      color = NA
    ),
    panel.background = element_rect(
      fill = "white",
      color = NA
    )
  )

8. EVALUACIÓN DEL MODELO

pearson_modelo <- cor.test(
  y,
  y_estimado,
  method = "pearson"
)

r_pearson <- as.numeric(pearson_modelo$estimate)
p_valor <- pearson_modelo$p.value

tabla_evaluacion <- data.frame(
  Indicador = c(
    "Coeficiente de Pearson",
    "p-value",
    "R²",
    "RMSE"
  ),
  Valor = c(
    round(r_pearson, 4),
    format.pval(p_valor, digits = 4),
    round(r_cuadrado, 4),
    round(rmse, 2)
  ),
  Interpretacion = c(
    "Relación entre los valores observados y los valores estimados por la curva potencial",
    "Significancia estadística de la relación observada-estimada",
    "Variabilidad explicada por el modelo en la escala original",
    "Error promedio aproximado del modelo"
  )
)

knitr::kable(
  tabla_evaluacion,
  caption = "Evaluación del modelo potencial"
)
Evaluación del modelo potencial
Indicador Valor Interpretacion
Coeficiente de Pearson 0.8502 Relación entre los valores observados y los valores estimados por la curva potencial
p-value < 0.00000000000000022 Significancia estadística de la relación observada-estimada
R² 0.7228 Variabilidad explicada por el modelo en la escala original
RMSE 8.62 Error promedio aproximado del modelo

Test de evaluación del modelo potencial

Coeficiente de Pearson observado-estimado: r = 0.8502

p-value: < 0.00000000000000022

Con un nivel de significancia de 0.05, la relación entre los valores observados y los valores estimados por el modelo es estadísticamente significativa.

8.1. RESTRICCIONES DEL MODELO

Restricciones del modelo

Sí existe restricción matemática y estadística, ya que el modelo potencial fue construido con valores observados de precipitación acumulada en 7 días entre x = 0.5 mm y x = 507.07 mm.

Además, para este modelo se requiere que las variables sean positivas. En este caso, el índice mínimo de susceptibilidad observado fue 13.62.

Al introducir valores fuera del rango observado, el modelo puede generar predicciones poco consistentes, debido a que estaría realizando una extrapolación fuera de los datos analizados.

9. PRONÓSTICO DEL MODELO POTENCIAL

valor_propuesto <- median(x)

if (
  valor_propuesto < min_precipitacion ||
  valor_propuesto > max_precipitacion
) {
  
  valor_estimado <- median(x)
  
  observacion_estimacion <- paste(
    "El valor propuesto está fuera del rango observado.",
    "Se usó la mediana de la precipitación acumulada en 7 días para la demostración."
  )
  
} else {
  
  valor_estimado <- valor_propuesto
  
  observacion_estimacion <- "El valor propuesto está dentro del rango observado."
}

nuevo_evento <- data.frame(
  precipitation_7d_mm = valor_estimado
)

susceptibilidad_estimada <- predict(
  modelo_potencial,
  newdata = nuevo_evento
)

limite_inferior <- max(0, susceptibilidad_estimada - 1.96 * rmse)
limite_superior <- susceptibilidad_estimada + 1.96 * rmse

tabla_estimacion <- data.frame(
  Precipitacion_7_dias_mm = valor_estimado,
  Susceptibilidad_estimada = susceptibilidad_estimada,
  Limite_inferior_aproximado = limite_inferior,
  Limite_superior_aproximado = limite_superior
)

knitr::kable(
  tabla_estimacion,
  digits = 2,
  caption = "Pronóstico generado por el modelo potencial"
)
Pronóstico generado por el modelo potencial
Precipitacion_7_dias_mm Susceptibilidad_estimada Limite_inferior_aproximado Limite_superior_aproximado
62.74 75.8 58.91 92.69

Pronóstico del modelo potencial

Para una precipitación acumulada en 7 días de:

62.74 mm

El índice de susceptibilidad estimado es:

75.8

Rango aproximado:
58.91 a 92.69

Observación: El valor propuesto está dentro del rango observado.

10. CONCLUSIÓN DEL MODELO

Conclusión del modelo potencial

El modelo permitió evaluar la relación entre la precipitación acumulada en 7 días y el índice de susceptibilidad a deslizamientos mediante una función potencial.

El parámetro b = 0.269, por lo que la relación estimada es positiva creciente.

El coeficiente de Pearson entre los valores observados y los valores estimados fue r = 0.85, con un p-value = < 0.00000000000000022. La relación observada-estimada resultó estadísticamente significativa.

El modelo explica aproximadamente 72.28% de la variabilidad del índice de susceptibilidad a deslizamientos.

Su uso debe limitarse al rango observado de precipitación acumulada y entenderse como una asociación estadística, no como una causalidad absoluta.

FIN DEL MODELO

Modelo finalizado

La regresión potencial fue desarrollada usando como variable independiente la precipitación acumulada en 7 días y como variable dependiente el índice de susceptibilidad a deslizamientos. La representación visual principal corresponde a la curva potencial ajustada sobre la nube de puntos en la escala original de los datos.