Actividad 2

library(forecast)
library(tidyverse)
library(maps)

Descarga de archivo

poblacion <- read.csv("C:/Users/Adrian Quezada/Downloads/population.csv")

Entender 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

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 = "Población")

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 trumestral

#ts_texas <- ts(poblacion_texas$population, start = c(1900, 8), frequency = 12) # serie de tiempo Mensual

ts_texas

## Time Series:
## Start = 1900 
## End = 2019 
## Frequency = 1 
##   [1]  3055000  3132000  3210000  3291000  3374000  3459000  3546000  3636000
##   [9]  3727000  3821000  3922000  4016000  4107000  4207000  4300000  4368000
##  [17]  4444000  4563000  4666000  4631000  4723000  4853000  4955000  5077000
##  [25]  5210000  5332000  5453000  5577000  5675000  5762000  5844000  5907000
##  [33]  5961000  6014000  6053000  6123000  6192000  6250000  6301000  6360000
##  [41]  6425000  6585000  6711000  7012000  6876000  6826000  7197000  7388000
##  [49]  7626000  7623000  7776000  8111000  8314000  8336000  8382000  8660000
##  [57]  8830000  9070000  9252000  9405000  9624000  9820000 10053000 10159000
##  [65] 10270000 10378000 10492000 10599000 10819000 11045000 11198655 11509848
##  [73] 11759148 12019543 12268629 12568843 12904089 13193050 13500429 13888371
##  [81] 14338208 14746318 15331415 15751676 16007086 16272734 16561113 16621791
##  [89] 16667022 16806735 17044714 17339904 17650479 17996764 18338319 18679706
##  [97] 19006240 19355427 19712389 20044141 20944499 21319622 21690325 22030931
## [105] 22394023 22778123 23359580 23831983 24309039 24801761 25241971 25645629
## [113] 26084481 26480266 26964333 27470056 27914410 28295273 28628666 28995881

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

##      Point Forecast    Lo 95    Hi 95
## 2020       29398472 29199487 29597457
## 2021       29806827 29463665 30149990
## 2022       30215183 29742956 30687410
## 2023       30623538 30024100 31222977
## 2024       31031894 30303359 31760429
## 2025       31440249 30579246 32301253
## 2026       31848605 30851090 32846119
## 2027       32256960 31118581 33395339
## 2028       32665316 31381587 33949044
## 2029       33073671 31640070 34507272

plot(pronostico_texas, main= "Poblacion en Texas")

#Ejercicio en clase Lunes 17

Crear Mapa

## Crear Mapa de EUA por decada, con un gradiente de verde a rojo de la poblacion por estado desde 1950 hasta 2050

map(database = "state")
map(database = "state", regions = "Texas", col = "red", fill = TRUE, add = TRUE)
map(database = "state", regions = "New York", col = "green", fill = TRUE, add = TRUE)

library(ggplot2)
library(dplyr)
library(maps)
library(viridis)

## Cargando paquete requerido: viridisLite

## 
## Adjuntando el paquete: 'viridis'

## The following object is masked from 'package:maps':
## 
##     unemp

library(tidyr)

# Crear un dataframe con los nombres completos de los estados
state_names <- data.frame(
  state = state.abb,
  region = tolower(state.name)
)

# Unir los nombres completos al dataframe original
poblacion <- poblacion %>%
  left_join(state_names, by = "state")

# Pronóstico de población para años futuros (hasta 2050)
futuro <- poblacion %>%
  group_by(region) %>%
  do({
    modelo <- lm(population ~ year, data = .)
    años_futuros <- data.frame(year = seq(2020, 2050, by = 10))
    predicciones <- predict(modelo, newdata = años_futuros)
    data.frame(region = unique(.$region), year = años_futuros$year, population = predicciones)
  })

# Unir las proyecciones al dataset original
poblacion_completa <- bind_rows(poblacion, futuro)

# Filtrar solo las décadas
poblacion_decadas <- poblacion_completa %>%
  filter(year %% 10 == 0 & year >= 1950 & year <= 2050)

# Obtener datos del mapa de EE. UU.
states_map <- map_data("state")

# Unir el mapa con los datos de población
map_data_pop <- left_join(states_map, poblacion_decadas, by = "region")

## Warning in left_join(states_map, poblacion_decadas, by = "region"): Detected an unexpected many-to-many relationship between `x` and `y`.
## ℹ Row 1 of `x` matches multiple rows in `y`.
## ℹ Row 8 of `y` matches multiple rows in `x`.
## ℹ If a many-to-many relationship is expected, set `relationship =
##   "many-to-many"` to silence this warning.

# Crear el mapa
ggplot(map_data_pop, aes(x = long, y = lat, group = group, fill = population)) +
  geom_polygon(color = "white") +
  coord_fixed(1.3) +
  scale_fill_gradient(low = "green", high = "red", name = "Población") +
  facet_wrap(~year) +
  labs(title = "Población de Estados Unidos por Estado (1950-2050) con Proyecciones",
       x = "Longitud", y = "Latitud") +
  theme_minimal()

Act 2 lechitas Hersheys

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

Importar la base de datos

library(readxl)
ventas <- read_excel("C:/Users/Adrian Quezada/Downloads/Ventas_Históricas_Lechitas.xlsx")

1. Modelo AutoARIMA

ts_ventas<-ts(ventas$Ventas, start = c(2017,1), frequency=12) 
autoplot(ts_ventas) + labs(title= "Ventas de Leche Saborizada Hershey's", 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)) #Pronostico a 10 años h
pronostico_ventas

##          Point Forecast    Lo 95    Hi 95
## 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

autoplot(pronostico_ventas) + labs(title= "Pronóstico de ventas 2020 de Leche Saborizada Hershey's", x="Timepo", y="Miles de Dólares")

2. Modelo regresión 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= "Pronóstico de ventas 2020 de Leche Saborizada Hershey's", xlab = "Timepo", ylab ="Miles de Dólares" )
abline(regresion_ventas, col = "blue")
points(siguiente_anio$Mes, prediccion_regresion, col = "red")

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

## [1] 2.011297

3. Conclusiones

El mejor modelo que se adapta a la serie es el SARIMA con un MAPE de 0.70, comparado con la regresion lineal que su MAPE es 2.01%

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

Mes-Año Ecs.Esperado Ecs.Pesimista Ecs.Optimista

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 202 | 39779.02 | 38632.72 | 40925.32
Nov 2020 | 38741.63 | 37595.28 | 39887.97
Dec 2020 | 38645.86 | 37499.50 | 39792.22

ventas_por_anio <- read.csv("C:/Users/Adrian Quezada/Downloads/ventas_por_anio (2).csv")
ggplot(ventas_por_anio, 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= "Ventas")

Nuestra recomendación seria realizar campañas publicitatias para aumentar el consumo de leche saborizada Hersheys para los meses de invierno con climas frios