Actividad 2: Generación de escenarios futuros con modelos de pronósticos en series de tiempo.

Ejemplo en clase: Población (17/02/2025)

1. Instalar paquetes y llamar librerias

library(forecast)
library(tidyverse)
library(ggplot2)
library(readxl)

2. Importar la base de datos

poblacion <- read.csv("/Users/hectordelagarzatrevino/Library/CloudStorage/GoogleDrive-a01177960@tec.mx/My Drive/LIT/8. Octavo semestre/Generación de escenarios futuros con analítica/Modulo 1/Actividades/Actividad 2/population.csv")

3. Entendiendo la base de datos

summary(poblacion)

##     state                year        population      
##  Length:6020        Min.   :1900   Min.   :   43000  
##  Class :character   1st Qu.:1930   1st Qu.:  901483  
##  Mode  :character   Median :1960   Median : 2359000  
##                     Mean   :1960   Mean   : 3726003  
##                     3rd Qu.:1990   3rd Qu.: 4541883  
##                     Max.   :2019   Max.   :39512223

str(poblacion)

## 'data.frame':    6020 obs. of  3 variables:
##  $ state     : chr  "AK" "AK" "AK" "AK" ...
##  $ year      : int  1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 ...
##  $ population: int  135000 158000 189000 205000 215000 222000 224000 231000 224000 224000 ...

head(poblacion)

##   state year population
## 1    AK 1950     135000
## 2    AK 1951     158000
## 3    AK 1952     189000
## 4    AK 1953     205000
## 5    AK 1954     215000
## 6    AK 1955     222000

4. Serie de tiempo en Texas

poblacion_texas <- poblacion %>% filter(state=="TX")
ggplot(poblacion_texas, aes(x= year, y= population)) + 
  geom_line() +
  labs(title = "Poblacion de Texas", x = "Año",
       y = "Poblacion")

ts_texas <- ts(poblacion_texas$population, start = 1900, frequency = 1) # Serie de tiempo anual
# ts_texas <- ts(poblacion_texas$population, start = c(1900,4), frequency = 4) Serie de tiempo trimestral
# ts_texas <- ts(poblacion_texas$population, start = c(1900,8), frequency = 12) Serie de tiempo mensual
arima_texas <- auto.arima(ts_texas)
summary(arima_texas)

## Series: ts_texas 
## ARIMA(0,2,2) 
## 
## Coefficients:
##           ma1      ma2
##       -0.5950  -0.1798
## s.e.   0.0913   0.0951
## 
## sigma^2 = 1.031e+10:  log likelihood = -1527.14
## AIC=3060.28   AICc=3060.5   BIC=3068.6
## 
## Training set error measures:
##                    ME     RMSE      MAE       MPE      MAPE      MASE
## Training set 12147.62 99818.31 59257.39 0.1046163 0.5686743 0.2672197
##                     ACF1
## Training set -0.02136734

pronostico_texas <- forecast(arima_texas, level = 95, h = 10) # h es el numero de predicciones
plot(pronostico_texas, main = "Pronostico de población de Texas")

Ejercicio en clase (17/02/2025): Mapa

1.1 Instalar paquetes y llamar librerias

library(forecast)
library(tidyverse)
library(ggplot2)
library(maps)
library(palette)
library(leaflet)

2.1Entendiendo la base de datos

summary(poblacion)

##     state                year        population      
##  Length:6020        Min.   :1900   Min.   :   43000  
##  Class :character   1st Qu.:1930   1st Qu.:  901483  
##  Mode  :character   Median :1960   Median : 2359000  
##                     Mean   :1960   Mean   : 3726003  
##                     3rd Qu.:1990   3rd Qu.: 4541883  
##                     Max.   :2019   Max.   :39512223

str(poblacion)

## 'data.frame':    6020 obs. of  3 variables:
##  $ state     : chr  "AK" "AK" "AK" "AK" ...
##  $ year      : int  1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 ...
##  $ population: int  135000 158000 189000 205000 215000 222000 224000 231000 224000 224000 ...

head(poblacion)

##   state year population
## 1    AK 1950     135000
## 2    AK 1951     158000
## 3    AK 1952     189000
## 4    AK 1953     205000
## 5    AK 1954     215000
## 6    AK 1955     222000

3.1 Serie de tiempo en Texas

poblacion_texas <- poblacion %>% filter(state=="TX")
ggplot(poblacion_texas, aes(x= year, y= population)) + 
  geom_line() +
  labs(title = "Poblacion de Texas", x = "Año",
       y = "Poblacion")

ts_texas <- ts(poblacion_texas$population, start = 1900, frequency = 1) # Serie de tiempo anual
# ts_texas <- ts(poblacion_texas$population, start = c(1900,4), frequency = 4) Serie de tiempo trimestral
# ts_texas <- ts(poblacion_texas$population, start = c(1900,8), frequency = 12) Serie de tiempo mensual
arima_texas <- auto.arima(ts_texas)
summary(arima_texas)

## Series: ts_texas 
## ARIMA(0,2,2) 
## 
## Coefficients:
##           ma1      ma2
##       -0.5950  -0.1798
## s.e.   0.0913   0.0951
## 
## sigma^2 = 1.031e+10:  log likelihood = -1527.14
## AIC=3060.28   AICc=3060.5   BIC=3068.6
## 
## Training set error measures:
##                    ME     RMSE      MAE       MPE      MAPE      MASE
## Training set 12147.62 99818.31 59257.39 0.1046163 0.5686743 0.2672197
##                     ACF1
## Training set -0.02136734

pronostico_texas <- forecast(arima_texas, level = 95, h = 10) # h es el numero de predicciones
plot(pronostico_texas, main = "Pronostico de población de Texas")

4.1 Crear un mapa

# Crear un mapa de EUA por decada, con un gradiente verde-rojo de la poblacion por estado, desde 1900 hasta 2050
map(database = "state")
map(database = "state", regions = "Texas", col = "red", fill = TRUE, add = TRUE)
map(database = "state", regions = "New York", col = "blue", fill = TRUE, add = TRUE)

5.1 Actividad de Mapa

# Generar pronósticos con ARIMA para cada estado
proyecciones <- poblacion %>%
  group_by(state) %>%
  summarise(
    modelo = list(auto.arima(ts(population, start = 1950, frequency = 1))),  # Modelo ARIMA
    .groups = "drop"
  ) %>%
  rowwise() %>%
  mutate(
    pronostico = list(forecast(modelo, h = 31)),  # Pronóstico de 5 años
    poblacion5 = tail(pronostico$mean, 1)  # Obtener la población del último año pronosticado
  ) %>%
  select(state, poblacion5)

# Unir proyecciones con el mapa
states <- map("state", plot = FALSE, fill = TRUE)
map_data <- merge(data.frame(state = tolower(state.name)), proyecciones, by = "state", all.x = TRUE)


# Asignar colores según la población (gradiente verde-rojo)
color_pal <- colorNumeric(palette = "RdYlGn", domain = proyecciones$poblacion5)

# Crear mapa interactivo con Leaflet
leaflet(data = states) %>%
  addTiles() %>%
  addPolygons(
    fillColor = ~color_pal(proyecciones$poblacion5),
    fillOpacity = 0.7,
    color = "black",
    weight = 1,
    popup = ~paste("Estado:", proyecciones$state, "<br>",
                   "Población en 5 años:", format(proyecciones$poblacion5, big.mark = ","))
  ) %>%
  addLegend(
    "bottomright",
    pal = color_pal,
    values = proyecciones$poblacion5,
    title = "Población pronosticada en 5 Años",
    opacity = 1
  )

Actividad 2. Leche saborizada Hershey´s

1.2 Instalar paquetes y llamar librerias

library(forecast)
library(tidyverse)
library(ggplot2)
library(readxl)

2.2 Importar la base de datos

ventas <- read_excel("/Users/hectordelagarzatrevino/Library/CloudStorage/GoogleDrive-a01177960@tec.mx/My Drive/LIT/8. Octavo semestre/Generación de escenarios futuros con analítica/Modulo 1/Actividades/Actividad 2/Ventas_Históricas_lechitas.xlsx")

3.2 Modelo AUTO.ARIMA

ts_ventas <- ts(ventas$Ventas, start = c(2017,1), frequency = 12)
autoplot(ts_ventas) + labs(title = "Ventas de leche saborizada Hersheys", x = "Tiempo", y = "Miles de dolares")

arima_ventas <- auto.arima(ts_ventas)
summary(arima_ventas)

## Series: ts_ventas 
## ARIMA(1,0,0)(1,1,0)[12] with drift 
## 
## Coefficients:
##          ar1     sar1     drift
##       0.6383  -0.5517  288.8979
## s.e.  0.1551   0.2047   14.5026
## 
## sigma^2 = 202701:  log likelihood = -181.5
## AIC=371   AICc=373.11   BIC=375.72
## 
## Training set error measures:
##                    ME    RMSE    MAE        MPE      MAPE       MASE      ACF1
## Training set 25.22158 343.864 227.17 0.08059932 0.7069542 0.06491044 0.2081026

pronostico_ventas <- forecast(arima_ventas, level = 95, h = 12) 
autoplot(pronostico_ventas, main = "Pronostico de ventas de leche saborizada Hersheys")

4.2 Modelo Regresion Lineal

ventas$mes <- 1:36
regresion_ventas <- lm(Ventas ~ mes, data = ventas)
summary(regresion_ventas)

## 
## Call:
## lm(formula = Ventas ~ mes, data = ventas)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -2075.79  -326.41    33.74   458.40  1537.04 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 24894.67     275.03   90.52   <2e-16 ***
## mes           298.37      12.96   23.02   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 808 on 34 degrees of freedom
## Multiple R-squared:  0.9397, Adjusted R-squared:  0.9379 
## F-statistic: 529.8 on 1 and 34 DF,  p-value: < 2.2e-16

siguiente_anio <- data.frame(mes=37:48)
prediccion_regresion <- predict(regresion_ventas, siguiente_anio)
prediccion_regresion

##        1        2        3        4        5        6        7        8 
## 35934.49 36232.86 36531.23 36829.61 37127.98 37426.35 37724.73 38023.10 
##        9       10       11       12 
## 38321.47 38619.85 38918.22 39216.59

plot(ventas$mes, ventas$Ventas, main = "Pronostico de ventas de Hersheys", xlab = "Tiempo", ylab = "Miles de dolares")
abline(regresion_ventas, col = "blue")
points(siguiente_anio$mes, prediccion_regresion, col = "red")

predicciones_reales <- predict(regresion_ventas, ventas)
MAPE <- mean(abs((ventas$Ventas - predicciones_reales)/ventas$Ventas))*100
MAPE

## [1] 2.011297

5.2 Conclusiones

El mejor modelo que se adapta a la serie es el SARIMA con un Mape de 0.71%, comparado con la Regresion Lineal que su MAPE es de 2.01%

Para el siguiente año, la proyección de ventas es la siguiente:

Mes y Año	Escenario Optimista	Escenario Esperado	Escenario Pesimista
Jan 2020	35498.90	34616.48	36381.32
Feb 2020	34202.17	33155.28	35249.05
Mar 2020	36703.01	35596.10	37809.92
Apr 2020	36271.90	35141.44	37402.36
May 2020	37121.98	35982.07	38261.90
Jun 2020	37102.65	35958.90	38246.40
Jul 2020	37151.04	36005.73	38296.34
Aug 2020	38564.64	37418.70	39710.58
Sep 2020	38755.22	37609.03	39901.42
Oct 2020	39779.02	38632.72	40925.32
Nov 2020	38741.63	37595.28	39887.97
Dec 2020	38645.86	37499.50	39792.22

ventasporanio <- read_excel("/Users/hectordelagarzatrevino/Library/CloudStorage/GoogleDrive-a01177960@tec.mx/My Drive/LIT/8. Octavo semestre/Generación de escenarios futuros con analítica/Modulo 1/Actividades/Actividad 2/Ventas2.xlsx")
ggplot(ventasporanio, aes(x = Mes,y= Ventas, col=as.factor(Anio), group=Anio))+
  geom_line() + labs(title = "Ventas de Leche Saborizada Hershey's por Año", x="Mes", y= "Miles de Dólares")

Nuestra recomendación sería realizar campañas publicitarias para aumentar el consumo de leche saborizada Hershey’s en el primer semestre del año.