0. Librerias 1. Datos 2. Variable 3. Frecuencias 4. Grafica 5. Conjetura 6. Parametros 7. Sobreposicion 8. Bondad 9. Probabilidades 10. Intervalo 11. Conclusion

0. CARGA DE LIBRERIAS

library(readxl)
library(dplyr)
library(gt)

tabla_gt <- function(datos, numero, titulo){
  datos %>%
    gt() %>%
    tab_header(
      title=md(paste0("**Tabla N. ",numero,"**")),
      subtitle=md(titulo)
    ) %>%
    tab_options(table.width=pct(100)) %>%
    tab_source_note(
      source_note=md("Elaborado por: Grupo 1 - Carrera de Geologia")
    )
}

1. CARGA DE DATOS

datos <- read_excel("datos_nuevoartes_.xlsx")

2. PREPARACION DE LA VARIABLE

La distribución de Poisson modela la cantidad de eventos ocurridos en intervalos iguales. Por ello se contará el número de deslizamientos registrado durante cada año.

\[ X=\text{cantidad de deslizamientos por año} \]

anio <- as.integer(format(datos$event_date,"%Y"))
anio <- anio[!is.na(anio)]

anios <- min(anio):max(anio)

conteos <- as.integer(
  table(factor(anio,levels=anios))
)

tabla_anual <- data.frame(
  Anio=anios,
  Cantidad=conteos
)

n <- length(conteos)
total_eventos <- sum(conteos)
tabla_gt(
  tabla_anual,
  1,
  "Cantidad de deslizamientos registrada durante cada anio"
) %>%
  fmt_number(columns=Anio,decimals=0,use_seps=FALSE)
Tabla N. 1
Cantidad de deslizamientos registrada durante cada anio
Anio Cantidad
1988 1
1989 0
1990 0
1991 0
1992 0
1993 1
1994 0
1995 1
1996 2
1997 10
1998 12
1999 0
2000 0
2001 0
2002 0
2003 2
2004 1
2005 2
2006 13
2007 408
2008 699
2009 379
2010 1528
2011 1304
2012 782
2013 1117
2014 1034
2015 1339
2016 1171
2017 1227
Elaborado por: Grupo 1 - Carrera de Geologia

3. TABLA DE FRECUENCIAS

La tabla muestra cuántos años presentaron cada cantidad anual de deslizamientos.

frecuencias <- as.data.frame(table(conteos))
names(frecuencias) <- c("X","Cantidad_anios")

frecuencias$X <- as.integer(
  as.character(frecuencias$X)
)

frecuencias$Porcentaje <- 
  frecuencias$Cantidad_anios/n*100
tabla_gt(
  frecuencias,
  2,
  "Distribucion observada del numero anual de deslizamientos"
) %>%
  cols_label(
    X="Deslizamientos por anio",
    Cantidad_anios="Cantidad de anios",
    Porcentaje="Porcentaje (%)"
  ) %>%
  fmt_number(columns=Porcentaje,decimals=2)
Tabla N. 2
Distribucion observada del numero anual de deslizamientos
Deslizamientos por anio Cantidad de anios Porcentaje (%)
0 9 30.00
1 4 13.33
2 3 10.00
10 1 3.33
12 1 3.33
13 1 3.33
379 1 3.33
408 1 3.33
699 1 3.33
782 1 3.33
1034 1 3.33
1117 1 3.33
1171 1 3.33
1227 1 3.33
1304 1 3.33
1339 1 3.33
1528 1 3.33
Elaborado por: Grupo 1 - Carrera de Geologia

4. GRAFICA DE FRECUENCIAS

par(mar=c(8,5,4,2))

pos <- barplot(
  conteos,
  names.arg=anios,
  col="#D8C3CA",
  border="#6D213C",
  las=2,
  cex.names=.7,
  ylim=c(0,max(conteos)*1.15),
  main="Cantidad anual de deslizamientos\na nivel mundial",
  xlab="",
  ylab="Cantidad"
)

text(
  pos,
  conteos,
  labels=conteos,
  pos=3,
  cex=.6,
  font=2
)

mtext("Anio de ocurrencia",side=1,line=6)

5. CONJETURA DEL MODELO

La distribución de Poisson representa el número de eventos que ocurre dentro de un intervalo fijo de tiempo.

Su función de probabilidad es:

\[ P(X=x)=\frac{e^{-\lambda}\lambda^x}{x!} \]

donde:

Se plantea:

\[ X\sim Poisson(\lambda) \]

Las hipótesis son:

\[ H_0: \text{La cantidad anual de deslizamientos sigue una distribucion de Poisson} \]

\[ H_1: \text{La cantidad anual de deslizamientos no sigue una distribucion de Poisson} \]

El modelo supone intervalos anuales iguales, independencia entre eventos y una tasa aproximadamente constante.

6. ESTIMACION DE PARAMETROS

Para Poisson:

\[ E(X)=Var(X)=\lambda \]

El parámetro se estima mediante:

\[ \hat{\lambda}=\bar{x} \]

lambda <- mean(conteos)
varianza <- var(conteos)
desviacion <- sd(conteos)
indice_dispersion <- varianza/lambda

parametros <- data.frame(
  Parametro=c(
    "Periodos analizados",
    "Total de eventos",
    "Lambda estimado",
    "Varianza observada",
    "Desviacion observada",
    "Desviacion teorica",
    "Indice de dispersion"
  ),
  Resultado=c(
    n,
    total_eventos,
    lambda,
    varianza,
    desviacion,
    sqrt(lambda),
    indice_dispersion
  )
)
tabla_gt(
  parametros,
  3,
  "Parametros estimados del modelo de Poisson"
) %>%
  fmt_number(columns=Resultado,decimals=4)
Tabla N. 3
Parametros estimados del modelo de Poisson
Parametro Resultado
Periodos analizados 30.0000
Total de eventos 11,033.0000
Lambda estimado 367.7667
Varianza observada 288,787.0816
Desviacion observada 537.3891
Desviacion teorica 19.1772
Indice de dispersion 785.2454
Elaborado por: Grupo 1 - Carrera de Geologia

7. SOBREPOSICION CON EL MODELO DE POISSON

La realidad y el modelo se comparan utilizando cuatro grupos definidos mediante los cuartiles teóricos de Poisson.

cortes <- qpois(
  c(.25,.50,.75),
  lambda=lambda
)

limites <- c(-Inf,cortes,Inf)

grupos <- cut(
  conteos,
  breaks=limites,
  right=TRUE
)

Fo <- as.numeric(table(grupos))

P <- diff(
  ppois(
    limites,
    lambda=lambda
  )
)

Fe <- n*P

comparacion <- data.frame(
  Intervalo=levels(grupos),
  Observado=Fo,
  Esperado=Fe,
  Porcentaje_observado=Fo/n*100,
  Porcentaje_Poisson=P*100
)
tabla_gt(
  comparacion,
  4,
  "Comparacion entre la realidad y el modelo de Poisson"
) %>%
  fmt_number(
    columns=c(
      Esperado,
      Porcentaje_observado,
      Porcentaje_Poisson
    ),
    decimals=4
  )
Tabla N. 4
Comparacion entre la realidad y el modelo de Poisson
Intervalo Observado Esperado Porcentaje_observado Porcentaje_Poisson
(-Inf,355] 19 7.8862 63.3333 26.2874
(355,368] 0 7.6751 0.0000 25.5837
(368,381] 1 7.3693 3.3333 24.5643
(381, Inf] 10 7.0694 33.3333 23.5646
Elaborado por: Grupo 1 - Carrera de Geologia 
datos_grafica <- rbind(
  Realidad=comparacion$Porcentaje_observado,
  Poisson=comparacion$Porcentaje_Poisson
)

par(mar=c(7,5,4,2))

barplot(
  datos_grafica,
  beside=TRUE,
  names.arg=comparacion$Intervalo,
  col=c("#D8C3CA","#6D213C"),
  border="#4A1026",
  las=2,
  ylim=c(0,max(datos_grafica)*1.2),
  main="Distribucion observada y modelo de Poisson",
  ylab="Porcentaje (%)"
)

legend(
  "topright",
  legend=c("Realidad","Poisson"),
  fill=c("#D8C3CA","#6D213C"),
  bty="n"
)

8. TEST DE BONDAD DE AJUSTE

8.1 Coeficiente de Pearson

pearson <- cor(Fo,Fe)*100

8.2 Grafico Q-Q

observados <- sort(conteos)

teoricos <- qpois(
  (seq_along(observados)-.5)/n,
  lambda=lambda
)

plot(
  teoricos,
  observados,
  pch=19,
  col="#6D213C",
  main="Grafico Q-Q de Poisson",
  xlab="Cuantiles teoricos",
  ylab="Conteos observados"
)

abline(0,1,col="#4A1026",lwd=2)
grid()

8.3 Contraste chi-cuadrado

Como se estimó un parámetro, los grados de libertad son:

\[ gl=k-1-1 \]

chi_calculado <- sum((Fo-Fe)^2/Fe)
gl <- length(Fo)-2
chi_critico <- qchisq(.95,gl)
p_chi <- pchisq(chi_calculado,gl,lower.tail=FALSE)

decision_chi <- ifelse(
  p_chi>=.05,
  "No se rechaza H0",
  "Se rechaza H0"
)

8.4 Prueba de dispersión

Para Poisson, la media y la varianza deben ser aproximadamente iguales.

\[ ID=\frac{s^2}{\bar{x}} \]

estadistico_dispersion <- (n-1)*indice_dispersion

p_dispersion <- 2*min(
  pchisq(estadistico_dispersion,n-1),
  pchisq(
    estadistico_dispersion,
    n-1,
    lower.tail=FALSE
  )
)

p_dispersion <- min(1,p_dispersion)

decision_dispersion <- ifelse(
  p_dispersion>=.05,
  "No se rechaza la equidispersion",
  "Se rechaza la equidispersion"
)
bondad <- data.frame(
  Indicador=c(
    "Pearson (%)",
    "Chi-cuadrado calculado",
    "Grados de libertad",
    "Chi-cuadrado critico",
    "Valor p chi-cuadrado",
    "Decision",
    "Indice de dispersion",
    "Valor p dispersion",
    "Decision de dispersion"
  ),
  Resultado=c(
    round(pearson,2),
    round(chi_calculado,4),
    gl,
    round(chi_critico,4),
    round(p_chi,6),
    decision_chi,
    round(indice_dispersion,4),
    round(p_dispersion,6),
    decision_dispersion
  )
)

tabla_gt(
  bondad,
  5,
  "Bondad de ajuste del modelo de Poisson"
)
Tabla N. 5
Bondad de ajuste del modelo de Poisson
Indicador Resultado
Pearson (%) 30.48
Chi-cuadrado calculado 30.0573
Grados de libertad 2
Chi-cuadrado critico 5.9915
Valor p chi-cuadrado 0
Decision Se rechaza H0
Indice de dispersion 785.2454
Valor p dispersion 0
Decision de dispersion Se rechaza la equidispersion
Elaborado por: Grupo 1 - Carrera de Geologia

9. CALCULO DE PROBABILIDADES

Se calcula la probabilidad de registrar una cantidad anual dentro de una desviación estándar teórica alrededor de \(\lambda\).

\[ P\left( \lambda-\sqrt{\lambda} \leq X\leq \lambda+\sqrt{\lambda} \right) \]

Li_prob <- max(
  0,
  floor(lambda-sqrt(lambda))
)

Ls_prob <- ceiling(
  lambda+sqrt(lambda)
)

p_central <- ppois(Ls_prob,lambda)-
  ppois(Li_prob-1,lambda)

probabilidades <- data.frame(
  Evento=c(
    paste0("X menor que ",Li_prob),
    paste0(Li_prob," <= X <= ",Ls_prob),
    paste0("X mayor que ",Ls_prob)
  ),
  Probabilidad=c(
    ppois(Li_prob-1,lambda),
    p_central,
    1-ppois(Ls_prob,lambda)
  )
)

probabilidades$Porcentaje <- 
  probabilidades$Probabilidad*100
tabla_gt(
  probabilidades,
  6,
  "Probabilidades calculadas mediante Poisson"
) %>%
  fmt_number(
    columns=Probabilidad,
    decimals=6
  ) %>%
  fmt_number(
    columns=Porcentaje,
    decimals=2
  )
Tabla N. 6
Probabilidades calculadas mediante Poisson
Evento Probabilidad Porcentaje
X menor que 348 0.145035 14.50
348 <= X <= 387 0.703134 70.31
X mayor que 387 0.151831 15.18
Elaborado por: Grupo 1 - Carrera de Geologia 
x <- qpois(.001,lambda):qpois(.999,lambda)
px <- dpois(x,lambda)*100

colores <- ifelse(
  x>=Li_prob & x<=Ls_prob,
  "#6D213C",
  "#D8C3CA"
)

plot(
  x,
  px,
  type="h",
  lwd=3,
  col=colores,
  main="Probabilidad central del modelo de Poisson",
  xlab="Deslizamientos por anio",
  ylab="Porcentaje (%)"
)

abline(v=lambda,col="#4A1026",lty=2,lwd=2)
grid()

10. INTERVALO DE CONFIANZA

Se construye un intervalo de confianza exacto del 95 % para la tasa media anual.

ic <- poisson.test(
  total_eventos,
  T=n,
  conf.level=.95
)$conf.int

tabla_ic <- data.frame(
  Indicador=c(
    "Tasa media anual",
    "Limite inferior 95 %",
    "Limite superior 95 %"
  ),
  Resultado=c(
    lambda,
    ic[1],
    ic[2]
  )
)
tabla_gt(
  tabla_ic,
  7,
  "Intervalo de confianza para la tasa media anual"
) %>%
  fmt_number(columns=Resultado,decimals=4)
Tabla N. 7
Intervalo de confianza para la tasa media anual
Indicador Resultado
Tasa media anual 367.7667
Limite inferior 95 % 360.9359
Limite superior 95 % 374.6942
Elaborado por: Grupo 1 - Carrera de Geologia

11. CONCLUSION

tipo_dispersion <- ifelse(
  indice_dispersion>1.2,
  "sobredispersion",
  ifelse(
    indice_dispersion<.8,
    "subdispersion",
    "equidispersion aproximada"
  )
)

ajuste_final <- ifelse(
  p_chi>=.05 && p_dispersion>=.05,
  "el modelo de Poisson presenta un ajuste aceptable",
  "el modelo de Poisson no representa adecuadamente la distribucion observada"
)

cat(
  paste0(
    "Se analizaron **",n," años**, desde **",
    min(anios)," hasta ",max(anios),
    "**. La media estimada fue de **",
    round(lambda,2),
    " deslizamientos por año** y la varianza fue de **",
    round(varianza,2),"**.\n\n",

    "El índice de dispersión fue de **",
    round(indice_dispersion,2),
    "**, indicando ",tipo_dispersion,
    ". ",decision_dispersion,".\n\n",

    "El coeficiente de Pearson fue de **",
    round(pearson,2),
    " %** y el valor p del chi-cuadrado fue de **",
    round(p_chi,6),
    "**. Por tanto, ",ajuste_final,".\n\n",

    "La probabilidad de registrar entre **",
    Li_prob," y ",Ls_prob,
    " deslizamientos en un año** es de **",
    round(p_central*100,2),
    " %**.\n\n",

    "Con un nivel de confianza del 95 %, la tasa media anual se encuentra entre **",
    round(ic[1],2)," y ",round(ic[2],2),
    " deslizamientos por año**."
  )
)

Se analizaron 30 años, desde 1988 hasta 2017. La media estimada fue de 367.77 deslizamientos por año y la varianza fue de 288787.08.

El índice de dispersión fue de 785.25, indicando sobredispersion. Se rechaza la equidispersion.

El coeficiente de Pearson fue de 30.48 % y el valor p del chi-cuadrado fue de 0. Por tanto, el modelo de Poisson no representa adecuadamente la distribucion observada.

La probabilidad de registrar entre 348 y 387 deslizamientos en un año es de 70.31 %.

Con un nivel de confianza del 95 %, la tasa media anual se encuentra entre 360.94 y 374.69 deslizamientos por año.