ANÁLISIS ESTADÍSTICO

CARGA DE DATOS Y LIBRERÍAS

La variable año de descubrimiento es una variable discreta pero debido a su gran cantidad de diferentes años se decidio agruparlos en intervalos, La cual la trabajaremos como una variable continua

CARGA DE DATOS

#Carga de datos
setwd("~/UNI/ESTADISTICA")
datos  <- read.csv("Depositos_Sulfuro.csv", sep = ";", dec = ".", header = TRUE)

CARGA DE LIBRERIAS

#Carga de librerias
library(dplyr)
library(knitr)
library(gt)

TABLA DE DISTRIBUCION DE FRECUENCIA

# LIMPIEZA DE LA VARIABLE AÑO DE DESCUBRIMIENTO
año_descubrimiento <- as.numeric(datos$discdate)
año_descubrimiento<- na.omit(año_descubrimiento)

# SEPARAR OUTLIERS
caja <- boxplot(año_descubrimiento, plot = FALSE)

limite_sup <- caja$stats[5]
limite_inf <- caja$stats[1]

año_outliers <- año_descubrimiento[año_descubrimiento < limite_inf | año_descubrimiento > limite_sup]
año_sin_outliers <- año_descubrimiento[año_descubrimiento >= limite_inf & año_descubrimiento <= limite_sup]


# RESUMEN
cat("Cantidad con outliers:", length(año_descubrimiento), "\n")
## Cantidad con outliers: 823
cat("Cantidad de outliers:", length(año_outliers), "\n")
## Cantidad de outliers: 87
cat("Cantidad sin outliers:", length(año_sin_outliers), "\n")
## Cantidad sin outliers: 736
#TABLA DE DISTRIBUCION DE FRECUENCIA

#Crear un histograma para extraer información
histograma <- hist(año_sin_outliers,
                   plot = FALSE)
# Frecuencia absoluta (ni)
ni <- histograma$counts
# Frecuencia relativa (hi)
hi <- ni / sum(ni)*100
# Intervalos
intervalos <- paste0(
  "[", round(histograma$breaks[-length(histograma$breaks)], 2),
  ", ",
  round(histograma$breaks[-1], 2),
  ")"
)

# TABLA FINAL
tabla_frecuencias <- data.frame(
  Intervalo = intervalos,
  ni = ni,
  hi = round(hi, 2)
)

# Mostrar la tabla
tabla_frecuencias
##       Intervalo  ni    hi
## 1  [1780, 1800)   2  0.27
## 2  [1800, 1820)   2  0.27
## 3  [1820, 1840)   3  0.41
## 4  [1840, 1860)  18  2.45
## 5  [1860, 1880)  50  6.79
## 6  [1880, 1900)  67  9.10
## 7  [1900, 1920)  72  9.78
## 8  [1920, 1940)  91 12.36
## 9  [1940, 1960) 182 24.73
## 10 [1960, 1980) 184 25.00
## 11 [1980, 2000)  58  7.88
## 12 [2000, 2020)   7  0.95
# Mejorar la Tabla

tabla_AñoDesc_gt <- tabla_frecuencias %>%
  gt() %>%
  tab_header(
    title = md("**Tabla N° 1**"),
    subtitle = md("**Distribución de frecuencias de los Depósitos Masivos<br>
                     de Sulfuros Volcánicos por Año de descubrimiento**")
  ) %>%
  tab_source_note(
    source_note = md("Autor: Grupo 2")
  ) %>%
  tab_options(
    table.border.top.color = "black",
    table.border.bottom.color = "black",
    heading.border.bottom.color = "black",
    heading.border.bottom.width = px(2),
    column_labels.border.top.color = "black",
    column_labels.border.bottom.color = "black",
    column_labels.border.bottom.width = px(2),
    table_body.hlines.color = "gray",
    table_body.border.bottom.color = "black",
    row.striping.include_table_body = TRUE
  )

tabla_AñoDesc_gt
Tabla N° 1
Distribución de frecuencias de los Depósitos Masivos
de Sulfuros Volcánicos por Año de descubrimiento
Intervalo ni hi
[1780, 1800) 2 0.27
[1800, 1820) 2 0.27
[1820, 1840) 3 0.41
[1840, 1860) 18 2.45
[1860, 1880) 50 6.79
[1880, 1900) 67 9.10
[1900, 1920) 72 9.78
[1920, 1940) 91 12.36
[1940, 1960) 182 24.73
[1960, 1980) 184 25.00
[1980, 2000) 58 7.88
[2000, 2020) 7 0.95
Autor: Grupo 2

GRÁFICA DE DISTRIBUCIÓN DE PROBABILIDAD

#Gráfica de la variable

histograma<-hist(año_sin_outliers,
                 freq = FALSE,
                 main="Gráfica 1. Distribucion de densidad
                 de probabilidad de los años de 
                 descubrimiento",
                 xlab="Años de descubrimiento",
                 ylab="Densidad de probabilidad",
                 col="blue")

CONJETURA DEL MODELO

Debido a la similitud de las barras asociamos con el modelo de probabilidad log-normal

#Gráfica de modelo de probabilidad Log-normal

histograma<-hist(año_sin_outliers,
                 freq = FALSE,
                 main="Gráfica 2.Comparación de la realidad 
                 con el modelo log-normal de los años de
                 descubrimiento de los depositos masivos 
                 de sulfuros volcanicos",
                 xlab="Años de descubrimiento",
                 ylab="Densidad de probabilidad",
                 col="blue")

# Parámetros Log-normales

h<-length(histograma$counts)
medialog <- mean(log(año_sin_outliers)) 
sd_log<-sd(log(año_sin_outliers)) 
sd_log 
## [1] 0.02007509
medialog
## [1] 7.569578
x <- seq(min(año_sin_outliers),max(año_sin_outliers),0.01) 
curve(dlnorm(x,meanlog = medialog,sdlog = sd_log),add = TRUE,col=("black"),lwd=3)

#FECUENCIAS OBSERVADAS

Fo<-histograma$counts
Fo
##  [1]   2   2   3  18  50  67  72  91 182 184  58   7
#FRECUENCIAS ESPERADAS

P<-c(0) 
for (i in 1:h) {P[i] <-(plnorm(histograma$breaks[i+1],medialog,sd_log)- plnorm(histograma$breaks[i],medialog,sd_log))}
Fe<-P*length(año_sin_outliers)

Fe
##  [1]   0.07512467   0.54376466   2.87288572  11.18931715  32.43193083
##  [6]  70.59118021 116.38327584 146.55083914 142.06623872 106.83370746
## [11]  62.78028080  29.03355518

TEST DE APROBACIÓN

TEST DE PEARSON

#Tamaño muestral sin outliers

n<-length(año_sin_outliers)
n
## [1] 736
#Representar la frecuencia observada y esperada en porcentaje
Fo<-(Fo/n)*100
Fo
##  [1]  0.2717391  0.2717391  0.4076087  2.4456522  6.7934783  9.1032609
##  [7]  9.7826087 12.3641304 24.7282609 25.0000000  7.8804348  0.9510870
Fe<-(Fe/n)*100
Fe
##  [1]  0.01020716  0.07388107  0.39033773  1.52028766  4.40651234  9.59119296
##  [7] 15.81294509 19.91179880 19.30247809 14.51544938  8.52992946  3.94477652
#Correlacionar Fo y Fe
plot(Fo,Fe,main="Gráfica 3: Correlación de frecuencias 
     en el modelo log-normal del año de 
     descubrimiento",
     xlab="Frecuencia Observada(%)",
     ylab="Frecuencia esperada(%)",
     col="blue3")

abline(lm(Fe ~ Fo), col="red",lwd=2)

Correlación<-cor(Fo,Fe)*100

Correlación
## [1] 84.13727

APRUEBA EL TEST PEARSON

TEST DE CHI-CUADRADO

grados_libertad <- (length(histograma$counts)-1)
grados_libertad
## [1] 11
nivel_significancia <- 0.999   #Subir el nivel de significancia para aprobar el test de chi-cuadrado


x2<-sum((Fe-Fo)^2/Fe)
x2
## [1] 25.693
umbral_aceptacion <- qchisq(nivel_significancia, grados_libertad)
umbral_aceptacion
## [1] 31.26413
x2<umbral_aceptacion
## [1] TRUE

APRUEBA TEST DE CHI-CUADRADO

TABLA DE RESUMEN

Variable<-c("Año de descurbrimiento")
tabla_resumen<-data.frame(Variable,round(Correlación,2),round(x2,2),round(umbral_aceptacion,2))
colnames(tabla_resumen)<-c("Variable","Test Pearson (%)","Chi Cuadrado","Umbral de aceptación")
kable(tabla_resumen, format = "markdown", caption = "Tabla.Resumen de test de bondad al modelo de probabilidad")
Tabla.Resumen de test de bondad al modelo de probabilidad
Variable Test Pearson (%) Chi Cuadrado Umbral de aceptación
Año de descurbrimiento 84.14 25.69 31.26

CÁLCULO DE PROBABILIDADES

¿Cuál es la probabilidad de que un yacimiento haya sido descubierto entre los años 1950 y 2000?

# PROBABILIDAD ENTRE 1950 y 2000 

probabilidad_Año <- plnorm(2000, meanlog = medialog, sdlog = sd_log) -
  plnorm(1950,  meanlog = medialog, sdlog = sd_log)

# En porcentaje
probabilidad_Año * 100
## [1] 32.30579
# Rango para la curva 
x <- seq(min(año_sin_outliers), max(año_sin_outliers), 0.01)

# Curva log-normal
plot(x, dlnorm(x, meanlog = medialog, sdlog = sd_log),
     col = "skyblue3", 
     lwd = 2, 
     main = "Gráfica 4. Cálculo de probabilidades del año de 
     descubrimiento de los depositos masivos de sulfuros 
     volcanicos", 
     ylab = "Densidad de probabilidad",
     xlab = "Año de descubrimiento)")

# Rango del área de probabilidad
x_area <- seq(1950, 2000, 0.01) 
y_area <- dlnorm(x_area, meanlog = medialog, sdlog = sd_log)


# Línea del área 
lines(x_area, y_area, col = "red", lwd = 2)

# Área sombreada 
polygon(c(x_area, rev(x_area)), 
        c(y_area, rep(0, length(y_area))),
        col = rgb(1, 0, 0, 0.5), border = "black")
# Leyenda 
legend("topright",
       legend = c("Modelo Log-normal", "Área de Probabilidad"),
       col = c("skyblue3", "red"),
       lwd = 2, 
       pch = c(NA, 15), 
       cex = 0.5)
# TEXTO DE LA PROBABILIDAD EN LA GRÁFICA
texto_prob <- paste0("Probabilidad ",
                     round(probabilidad_Año*100, 2), " %")

text(x = 1850,
     y = max(dlnorm(x, medialog, sd_log)) * 0.7,
     labels = texto_prob,
     col = "black",
     cex = 0.7,
     font = 2)

CONCLUSIÓN