Segundo Avance Proyecto Prob. y Estadística

library(readxl)
BaseDeDatosPyE <- read_excel("BaseDeDatosPyE.xlsx", sheet = "blood_donor_dataset")

1. Análisis con Dos Variables.

- Correlación de Pearson:

# Calcular correlación de Pearson 
cor(BaseDeDatosPyE$"Meses Desde la Ultima Donacion",
    BaseDeDatosPyE$"Numero de Donaciones",
    method = "pearson")

## [1] 0.01043484

- Modelo lineal simple:

names(BaseDeDatosPyE) <- make.names(names(BaseDeDatosPyE))
names(BaseDeDatosPyE)

## [1] "Ciudad"                         "Grupo.Sanguineo"               
## [3] "Dispoibilidad"                  "Meses.Desde.la.Ultima.Donacion"
## [5] "Numero.de.Donaciones"

modelo <- lm(Numero.de.Donaciones ~ Meses.Desde.la.Ultima.Donacion, data = BaseDeDatosPyE)
summary(modelo)

## 
## Call:
## lm(formula = Numero.de.Donaciones ~ Meses.Desde.la.Ultima.Donacion, 
##     data = BaseDeDatosPyE)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -25.3824 -12.9444   0.6176  12.7402  25.1256 
## 
## Coefficients:
##                                 Estimate Std. Error t value Pr(>|t|)    
## (Intercept)                    24.865601   0.291223  85.383   <2e-16 ***
## Meses.Desde.la.Ultima.Donacion  0.004380   0.004198   1.043    0.297    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 14.65 on 9998 degrees of freedom
## Multiple R-squared:  0.0001089,  Adjusted R-squared:  8.877e-06 
## F-statistic: 1.089 on 1 and 9998 DF,  p-value: 0.2968

Interpretación del intercepto y pendiente:

El intercepto (24.86) representa el número estimado de donaciones cuando el tiempo desde la última donación es cero meses, mientras que la pendiente (0.00438) indica un aumento mínimo e insignificante del número de donaciones por cada mes adicional.

- Diagrama de cajas por grupos (x=Variable cualitativa, y= cuantitativa):

library(ggplot2)
ggplot(BaseDeDatosPyE, aes(x = Ciudad, y = Numero.de.Donaciones, fill = Ciudad)) +
  geom_boxplot() +
  ggtitle("Diagrama de cajas por grupos") +
  scale_fill_manual(values = c(
    "Adelaide" = "#A8DADC",   
    "Brisbane" = "#F4A261", 
    "Canberra" = "#E9C46A",  
    "Darwin" = "#B5E48C",     
    "Hobart" = "#FFCAD4",     
    "Melbourne" = "#90A955",  
    "Perth" = "#A2D2FF",      
    "Sydney" = "#6D597A"     
  )) +
  theme_minimal()

- Tabla cruzada:

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(ggplot2)

BaseDeDatosPyE %>%
  mutate(
    RangoMeses = cut(
      Meses.Desde.la.Ultima.Donacion,
      breaks = seq(0, max(Meses.Desde.la.Ultima.Donacion, na.rm = TRUE), by = 6),
      include.lowest = TRUE
    ),
    RangoDonaciones = cut(
      Numero.de.Donaciones,
      breaks = seq(0, max(Numero.de.Donaciones, na.rm = TRUE), by = 5),
      include.lowest = TRUE
    )
  ) %>%
  count(RangoMeses, RangoDonaciones) %>%
  ggplot(aes(
    x = RangoDonaciones,
    y = RangoMeses,
    fill = n
  )) +
  geom_tile(color = "white") +
  scale_fill_gradient(low = "white", high = "steelblue") +
  labs(
    title = "Relación entre Meses desde la Última Donación y Número de Donaciones",
    x = "Rango de Número de Donaciones",
    y = "Rango de Meses desde la Última Donación",
    fill = "Frecuencia"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

- Diagrama de barras apiladas:

library(dplyr)
library(ggplot2)

tabla <- BaseDeDatosPyE %>%
  count(RangoMeses = cut(Meses.Desde.la.Ultima.Donacion,
                         breaks = seq(0, max(Meses.Desde.la.Ultima.Donacion, na.rm = TRUE), by = 6),
                         include.lowest = TRUE),
        RangoDonaciones = cut(Numero.de.Donaciones,
                              breaks = seq(0, max(Numero.de.Donaciones, na.rm = TRUE), by = 2),
                              include.lowest = TRUE))

ggplot(tabla, aes(x = RangoMeses, y = n, fill = RangoDonaciones)) +
  geom_bar(stat = "identity", position = "stack") +
  labs(
    title = "Donaciones por rango de meses y rango de número de donaciones",
    x = "Rango de meses desde la última donación",
    y = "Frecuencia",
    fill = "Rango de donaciones"
  ) +
  theme_minimal() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

2. Pronósticos.

library(readxl)
library(dplyr)
library(ggplot2)
library(forecast)

## Registered S3 method overwritten by 'quantmod':
##   method            from
##   as.zoo.data.frame zoo

BaseDeDatosPyE <- read_excel("BaseDeDatosPyE.xlsx", sheet = "blood_donor_dataset")

#Agrupar los datos por los meses desde la última donación
serie <- BaseDeDatosPyE %>%
  group_by(`Meses Desde la Ultima Donacion`) %>%
  summarise(Donaciones = sum(`Numero de Donaciones`, na.rm = TRUE)) %>%
  arrange(`Meses Desde la Ultima Donacion`)

#Crear la serie temporal (usamos los meses como índice temporal)
ts_donaciones <- ts(serie$Donaciones, frequency = 12)

#Pronóstico con suavización exponencial
modelo_suav <- ets(ts_donaciones)
pronostico_suav <- forecast(modelo_suav, h = 12)

#Pronóstico con red neuronal (nnetar)
modelo_nnet <- nnetar(ts_donaciones)
pronostico_nnet <- forecast(modelo_nnet, h = 12)

#Gráfico comparando ambos pronósticos
autoplot(ts_donaciones) +
  autolayer(pronostico_suav$mean, series = "Suavización exponencial", color = "blue") +
  autolayer(pronostico_nnet$mean, series = "Red neuronal", color = "red") +
  ggtitle("Pronósticos del número de donaciones") +
  xlab("Meses desde la última donación") +
  ylab("Número de donaciones") +
  theme_minimal()