Análisis Inferencial del Año de Recolección

CARGA DE DATOS Y LIBRERÍAS

La variable Año de Recolección es de tipo discreta, sin embargo, debido a la gran cantidad de valores distintos, se procede a agruparla en intervalos, permitiendo tratarla como una variable continua para el Análisis Probabilístico

# Cargar dataset
datos <- read.csv("C:/Users/Grace/OneDrive - Universidad Central del Ecuador/Documentos/dataset_geologico_limpio_80.csv",
                  header = TRUE,
                  sep = ",",
                  dec = ".")

# Variable
year <- as.numeric(datos$YEAR_COLL)
year <- na.omit(year)
year <- year[year <= 2024]

# OMITIR OUTLIERS
caja <- boxplot(year, plot = FALSE)

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

year_sin_outliers <- year[year >= limite_inf & year <= limite_sup]

year <- year_sin_outliers

# 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, union

library(gt)

TABLA DE DISTRIBUCIÓN DE FRECUENCIAS

histograma <- hist(year, breaks = 4, plot = FALSE)

ni <- histograma$counts
total <- sum(ni)

hi <- round(ni/total, 4)

intervalos <- paste0(
  "[", round(histograma$breaks[-length(histograma$breaks)],0),
  ", ",
  round(histograma$breaks[-1],0), ")"
)

tabla <- data.frame(
  Intervalo = intervalos,
  ni = ni,
  hi = hi
)

tabla_total <- data.frame(
  Intervalo = "TOTAL",
  ni = sum(ni),
  hi = sum(hi)
)

tabla_final <- rbind(tabla, tabla_total)

# TABLA MEJORADA 
tabla_final %>%
  gt() %>%
  tab_header(
    title = md("**Tabla Nº1**"),
    subtitle = md("Tabla de distribución de cantidad del Año de Recolección
                  de Sedimentos Marinos")
  ) %>%
  tab_source_note(
    source_note = md("Autor: Grupo 3")
  )

Intervalo	ni	hi
Tabla Nº1
Tabla de distribución de cantidad del Año de Recolección de Sedimentos Marinos
[1940, 1960)	82	0.0030
[1960, 1980)	4406	0.1614
[1980, 2000)	16185	0.5931
[2000, 2020)	6602	0.2419
[2020, 2040)	16	0.0006
TOTAL	27291	1.0000
Autor: Grupo 3

GRÁFICA DE DISTRIBUCIÓN DE PROBABILIDAD

hist(year,
     freq = TRUE,
     breaks = 4,
     main="Gráfica Nº1: Distribución de cantidad del Año de Recolección 
     de Sedimentos Marinos",
     xlab="Año",
     ylab="Cantidad",
     col="blue")

CONJETURA DEL MODELO

Debido a la forma aproximadamente simétrica de la distribución y a la similitud de las barras del histograma, se asocia la variable Año de Recolección con un Modelo de probabilidad Normal.

## CONJETURA DEL MODELO NORMAL
histograma <- hist(year,
                   freq = FALSE,
                   breaks = 4,
                   main="Gráfica 2. Comparación de la realidad con el modelo de probabilidad
                   Normal del Año de Recolección de Sedimentos Marinos",
                   xlab="Año",
                   ylab="Densidad",
                   col="lightblue")

h <- length(histograma$counts)

media <- round(mean(year), 0)
sigma <- sd(year)

media

## [1] 1991

sigma

## [1] 13.58476

x <- seq(min(year), max(year), 0.01)

curve(dnorm(x, media, sigma),
      add = TRUE,
      col = "black",
      lwd = 3)

Fo <- histograma$counts

P <- c()

for (i in 1:h){
  P[i] <- pnorm(histograma$breaks[i+1], media, sigma) -
          pnorm(histograma$breaks[i], media, sigma)
}

Fe <- P * length(year)

TEST DE APROBACIÓN

TEST DE PEARSON

n <- length(year)

Fo_p <- (Fo/n)*100
Fe_p <- (Fe/n)*100

plot(Fo_p, Fe_p,
     main="Gráfica 3. Correlación de frecuencias en el Modelo Normal
     del Año de Recolección de Sedimentos Marinsode",
     xlab="Frecuencia Observada (%)",
     ylab="Frecuencia Esperada (%)",
     pch=19, col="blue")

abline(0,1,col="red",lwd=2)

correlacion <- cor(Fo_p, Fe_p)*100
correlacion

## [1] 99.622

TEST DE CHI-CUADRADO

# Grados de libertad
gl <- length(histograma$counts) - 1
gl

## [1] 4

chi2 <- sum((Fe_p - Fo_p)^2 / Fe_p)
chi2

## [1] 3.363255

# Nivel de significancia
umbral <- qchisq(0.95, gl)
umbral

## [1] 9.487729

# Decisión
chi2 < umbral

## [1] TRUE

Debido a que el modelo presenta un buen ajuste general, se considera adecuado para describir el comportamiento de la variable, aunque podrían evaluarse otros modelos en estudios posteriores.

TABLA RESUMEN

tabla_resumen <- data.frame(
  Variable = "Año de Recolección",
  "Test Pearson (%)" = round(correlacion,2),
  "Chi Cuadrado" = round(chi2,2),
  "Umbral de aceptación" = round(umbral,2)
)

tabla_resumen %>%
  gt() %>%
  tab_header(
    title = md("**Tabla Nº2**"),
    subtitle = md("Test de bondad de ajuste - Modelo Normal")
  )

Variable	Test.Pearson....	Chi.Cuadrado	Umbral.de.aceptación
Tabla Nº2
Test de bondad de ajuste - Modelo Normal
Año de Recolección	99.62	3.36	9.49

CÁLCULO DE PROBABILIDADES

¿Cuál es la probabilidad de que una muestra se encuentre dentro de un rango cercano a la media?

probabilidad <- pnorm(2010, media, sigma) - pnorm(1990, media, sigma)

probabilidad * 100

## [1] 44.83778

# GRÁFICA
x <- seq(min(year), max(year), 0.01)

plot(x, dnorm(x, media, sigma),
     col = "skyblue3",
     lwd = 2,
     main = "Gráfica 4. Cálculo de probabilidades",
     ylab = "Densidad",
     xlab = "Año")

x_area <- seq(1990, 2010, 0.01)
y_area <- dnorm(x_area, media, sigma)

lines(x_area, y_area, col = "red", lwd = 2)

polygon(c(x_area, rev(x_area)),
        c(y_area, rep(0, length(y_area))),
        col = rgb(1,0,0,0.5),
        border = NA)

legend("topright",
       legend = c("Modelo normal", "Área de probabilidad"),
       col = c("skyblue3", "red"),
       lwd = 2)

texto_prob <- paste0("Probabilidad = ",
                     round(probabilidad*100,2), "%")

text(mean(year),
     max(dnorm(x, media, sigma))*0.7,
     texto_prob)

Si se analizan 300 muestras nuevas, ¿cuántas de ellas se encontrarían en un rango cercano a la media de la variable?

cantidad <- probabilidad * 300
cantidad

## [1] 134.5133

INTERVALOS DE CONFIANZA

Debido al teorema del límite central, se puede estimar el intervalo en el cual se encuentra la media poblacional con un nivel de confianza del 95%.

## INTERVALOS DE CONFIANZA

# Media aritmética
x <- mean(year)
x

## [1] 1991.271

# Desviación estándar
sigma <- sd(year)
sigma

## [1] 13.58476

# Tamaño muestral
n <- length(year)
n

## [1] 27291

# Desviación estandar poblacional
e <- sigma/sqrt(n)
e

## [1] 0.08223229

# Intervalo de confianza (95%)
li <- x - 2*e
li

## [1] 1991.107

ls <- x + 2*e
ls

## [1] 1991.436

# TABLA MEJORADA
tabla_ic <- data.frame(
  "Límite inferior" = round(li,2),
  "Media" = round(x,2),
  "Límite superior" = round(ls,2),
  "Desv. estándar" = round(sigma,2),
  "Desviación estandar poblacional" = round(e,2)
)

tabla_ic %>%
  gt() %>%
  tab_header(
    title = md("**Tabla Nº3**"),
    subtitle = md("Intervalo de confianza del Año de Recolección")
  )

Límite.inferior	Media	Límite.superior	Desv..estándar	Desviación.estandar.poblacional
Tabla Nº3
Intervalo de confianza del Año de Recolección
1991.11	1991.27	1991.44	13.58	0.08

CONCLUSIÓN

La variable Año de Recolección se explica a través del modelo normal siendo la media aritmética de 1991 y una desviación estándar de 13.58.

De esta manera logramos calcular probabilidades como, por ejemplo, que al seleccionar aleatoriamente una muestra, la probabilidad de que se encuentre dentro de un rango cercano a la media es de 44.83.

Mediante el teorema del límite central, sabemos que la media aritmética poblacional del Año de Recolección se encuentra entre 1991.11 y 1991.44 con un 95% de confianza.