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
datos <- read.csv("C:\\Users\\joeja\\Desktop\\Proyecto Estadística\\Depositos_sulfuro.csv", 
                  header = TRUE, 
                  sep = ",", 
                  dec = ".")

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: 691

cat("Cantidad de outliers:", length(año_outliers), "\n")

## Cantidad de outliers: 59

cat("Cantidad sin outliers:", length(año_sin_outliers), "\n")

## Cantidad sin outliers: 632

#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  [1800, 1820)   2  0.32
## 2  [1820, 1840)   3  0.47
## 3  [1840, 1860)  12  1.90
## 4  [1860, 1880)  38  6.01
## 5  [1880, 1900)  51  8.07
## 6  [1900, 1920)  63  9.97
## 7  [1920, 1940)  71 11.23
## 8  [1940, 1960) 167 26.42
## 9  [1960, 1980) 165 26.11
## 10 [1980, 2000)  56  8.86
## 11 [2000, 2020)   4  0.63

# 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

Intervalo	ni	hi
Tabla N° 1
Distribución de frecuencias de los Depósitos Masivos de Sulfuros Volcánicos por Año de descubrimiento
[1800, 1820)	2	0.32
[1820, 1840)	3	0.47
[1840, 1860)	12	1.90
[1860, 1880)	38	6.01
[1880, 1900)	51	8.07
[1900, 1920)	63	9.97
[1920, 1940)	71	11.23
[1940, 1960)	167	26.42
[1960, 1980)	165	26.11
[1980, 2000)	56	8.86
[2000, 2020)	4	0.63
Autor: Grupo 2

GRÁFICA DE DISTRIBUCIÓN DE PROBABILIDAD

#Gráfica de la variable

histograma<-hist(año_sin_outliers,
                 freq = TRUE,
                 main="Gráfica 1. Distribucion de cantidad de 
                 los años de descubrimiento",
                 xlab="Años de descubrimiento",
                 ylab="Cantidad",
                 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.01923511

medialog

## [1] 7.571014

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   3  12  38  51  63  71 167 165  56   4

#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.2285537   1.4563216   6.6581499  22.0683014  53.5536301  96.0517899
##  [7] 128.4782878 129.2722966  98.6556162  57.5606531  25.8721891

TEST DE APROBACIÓN

TEST DE PEARSON

#Tamaño muestral sin outliers

n<-length(año_sin_outliers)
n

## [1] 632

#Representar la frecuencia observada y esperada en porcentaje
Fo<-(Fo/n)*100
Fo

##  [1]  0.3164557  0.4746835  1.8987342  6.0126582  8.0696203  9.9683544
##  [7] 11.2341772 26.4240506 26.1075949  8.8607595  0.6329114

Fe<-(Fe/n)*100
Fe

##  [1]  0.03616357  0.23043064  1.05350472  3.49181983  8.47367565 15.19806803
##  [7] 20.32884300 20.45447732 15.61006586  9.10769828  4.09370081

#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-1), col="red",lwd=2)

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

Correlación

## [1] 82.93052

APRUEBA EL TEST PEARSON

TEST DE CHI-CUADRADO

grados_libertad <- (length(histograma$counts)-1)
grados_libertad

## [1] 10

nivel_significancia <- 0.999   #Subir el nivel de significancia para aprobar el test de chi-cuadrado


x2<-sum((Fe-Fo)^2/Fe)
x2

## [1] 22.55098

umbral_aceptacion <- qchisq(nivel_significancia, grados_libertad)
umbral_aceptacion

## [1] 29.5883

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	82.93	22.55	29.59

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] 34.59746

# 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)

TEOREMA DEL LIMITE CENTRAL

#Media aritmetica
x<-mean(año_sin_outliers)
x

## [1] 1941.464

#Desviación estandar
sigma<-sd(año_sin_outliers)
sigma

## [1] 37.01795

#Tamaño muestral
n<-length(año_sin_outliers)
n

## [1] 632

#P(x-2e<u<x+2e)=95%
e<-sigma/sqrt(n)
e

## [1] 1.472495

li<-x-2*e
li

## [1] 1938.519

ls<-x+2*e
ls

## [1] 1944.409

tabla_media<-data.frame(round(li,2),Variable,round(ls,2),e)
colnames(tabla_media)<-c("Limite inferior","Media poblacional","Limite superior", "Desviación estandar poblacional")
library(knitr)
kable(tabla_media, format = "markdown", caption = "Tabla Nro.3: Media poblacional")

Tabla Nro.3: Media poblacional
Limite inferior	Media poblacional	Limite superior	Desviación estandar poblacional
1938.52	Año de descurbrimiento	1944.41	1.472495

CONCLUSIÓN

La variable año de descubrimiento se explica a través del modelo log-normal siendo la media aritmética de 1938.71 y una desviación estandar de 38.58.

De esta manera logramos calcular probabilidades como por ejemplo, que al seleccionar aleatoriamente cualquier área del año de descubrimiento donde se encuentre entre 1950 y 2000 es de 32.31 %

Mediante el teorema de limite central, sabemos que la media aritmética poblacional de los años de descubrimiento se encuentran entre 1935.87 y 1941.55 con un 95% de confianza.

Análisis inferencial de Depósitos Masivos de Sulfuro Volcánicos (Año de descubrimiento)

Grupo 2

2026-02-11