Actividad 2

#Ejemplo en Clase: Poblacion

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

##Descarga de archivo

#file.choose()
poblacion<- read.csv("C:/Users/ferna/Desktop/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 de Texas

poblacion_texas<-poblacion %>% filter(state=="TX")
poblacion_texas

##     state year population
## 1      TX 1900    3055000
## 2      TX 1901    3132000
## 3      TX 1902    3210000
## 4      TX 1903    3291000
## 5      TX 1904    3374000
## 6      TX 1905    3459000
## 7      TX 1906    3546000
## 8      TX 1907    3636000
## 9      TX 1908    3727000
## 10     TX 1909    3821000
## 11     TX 1910    3922000
## 12     TX 1911    4016000
## 13     TX 1912    4107000
## 14     TX 1913    4207000
## 15     TX 1914    4300000
## 16     TX 1915    4368000
## 17     TX 1916    4444000
## 18     TX 1917    4563000
## 19     TX 1918    4666000
## 20     TX 1919    4631000
## 21     TX 1920    4723000
## 22     TX 1921    4853000
## 23     TX 1922    4955000
## 24     TX 1923    5077000
## 25     TX 1924    5210000
## 26     TX 1925    5332000
## 27     TX 1926    5453000
## 28     TX 1927    5577000
## 29     TX 1928    5675000
## 30     TX 1929    5762000
## 31     TX 1930    5844000
## 32     TX 1931    5907000
## 33     TX 1932    5961000
## 34     TX 1933    6014000
## 35     TX 1934    6053000
## 36     TX 1935    6123000
## 37     TX 1936    6192000
## 38     TX 1937    6250000
## 39     TX 1938    6301000
## 40     TX 1939    6360000
## 41     TX 1940    6425000
## 42     TX 1941    6585000
## 43     TX 1942    6711000
## 44     TX 1943    7012000
## 45     TX 1944    6876000
## 46     TX 1945    6826000
## 47     TX 1946    7197000
## 48     TX 1947    7388000
## 49     TX 1948    7626000
## 50     TX 1949    7623000
## 51     TX 1950    7776000
## 52     TX 1951    8111000
## 53     TX 1952    8314000
## 54     TX 1953    8336000
## 55     TX 1954    8382000
## 56     TX 1955    8660000
## 57     TX 1956    8830000
## 58     TX 1957    9070000
## 59     TX 1958    9252000
## 60     TX 1959    9405000
## 61     TX 1960    9624000
## 62     TX 1961    9820000
## 63     TX 1962   10053000
## 64     TX 1963   10159000
## 65     TX 1964   10270000
## 66     TX 1965   10378000
## 67     TX 1966   10492000
## 68     TX 1967   10599000
## 69     TX 1968   10819000
## 70     TX 1969   11045000
## 71     TX 1970   11198655
## 72     TX 1971   11509848
## 73     TX 1972   11759148
## 74     TX 1973   12019543
## 75     TX 1974   12268629
## 76     TX 1975   12568843
## 77     TX 1976   12904089
## 78     TX 1977   13193050
## 79     TX 1978   13500429
## 80     TX 1979   13888371
## 81     TX 1980   14338208
## 82     TX 1981   14746318
## 83     TX 1982   15331415
## 84     TX 1983   15751676
## 85     TX 1984   16007086
## 86     TX 1985   16272734
## 87     TX 1986   16561113
## 88     TX 1987   16621791
## 89     TX 1988   16667022
## 90     TX 1989   16806735
## 91     TX 1990   17044714
## 92     TX 1991   17339904
## 93     TX 1992   17650479
## 94     TX 1993   17996764
## 95     TX 1994   18338319
## 96     TX 1995   18679706
## 97     TX 1996   19006240
## 98     TX 1997   19355427
## 99     TX 1998   19712389
## 100    TX 1999   20044141
## 101    TX 2000   20944499
## 102    TX 2001   21319622
## 103    TX 2002   21690325
## 104    TX 2003   22030931
## 105    TX 2004   22394023
## 106    TX 2005   22778123
## 107    TX 2006   23359580
## 108    TX 2007   23831983
## 109    TX 2008   24309039
## 110    TX 2009   24801761
## 111    TX 2010   25241971
## 112    TX 2011   25645629
## 113    TX 2012   26084481
## 114    TX 2013   26480266
## 115    TX 2014   26964333
## 116    TX 2015   27470056
## 117    TX 2016   27914410
## 118    TX 2017   28295273
## 119    TX 2018   28628666
## 120    TX 2019   28995881

ggplot(poblacion_texas, aes(x=year, y=population)) +
geom_line() +
  labs(tittle="Población 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) frecuency=4) 
#Serie de tiempo trimestral

# ts_texas<- ts(poblacion_texas$population, start = c(1900,8) frecuency=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)) #Pronostico a 10 años h
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="Población en Texas")

##Ejercicio en clase Lunes 17: Mapa

#install.packages("forecast")
library(forecast)
library(tidyverse)
library(ggplot2)
#install.packages("maps")
library(maps)

#file.choose()
poblacion<- read.csv("C:/Users/ferna/Desktop/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

##Crear un mapa

#Crear un mapa de EUA por década, con un gradiente verde-rojo de la población pos 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)

# Cargar librerías necesarias
library(ggplot2)
library(dplyr)
library(maps)
library(viridis)

## Loading required package: viridisLite

## 
## Attaching package: 'viridis'

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

library(tidyr)
library(scales)

## 
## Attaching package: 'scales'

## The following object is masked from 'package:viridis':
## 
##     viridis_pal

## The following object is masked from 'package:purrr':
## 
##     discard

## The following object is masked from 'package:readr':
## 
##     col_factor

# Simulación de datos de población (si no tienes datos reales)
set.seed(123)
años <- seq(1950, 2050, by = 10)
estados <- unique(map_data("state")$region)

poblacion <- expand.grid(region = estados, year = años) %>%
  mutate(population = round(runif(n(), min = 500000, max = 40000000), 0))

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

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

## Warning in left_join(states_map, poblacion, by = "region"): Detected an unexpected many-to-many relationship between `x` and `y`.
## ℹ Row 1 of `x` matches multiple rows in `y`.
## ℹ Row 1 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 con la escala de colores de rojo a verde (mayor a menor población)
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", labels = scales::comma) + 
  facet_wrap(~year) +
  labs(title = "Población de EE. UU. por Estado (1950-2050)",
       subtitle = "Los estados más poblados están en rojo y los menos poblados en verde",
       x = "Longitud", y = "Latitud") +
  theme_minimal()

Actividad 2. Leche Saborizada Hershey’s

Instalamos paquetes necesarios

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

Importar la base de datos

ventas<- read.csv("C:/Users/ferna/Desktop/Ventas_Históricas_Lechitas.csv")
View(ventas)

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.8980
## s.e.  0.1551   0.2047   14.5026
## 
## sigma^2 = 202700:  log likelihood = -181.5
## AIC=371   AICc=373.11   BIC=375.72
## 
## Training set error measures:
##                    ME    RMSE      MAE        MPE      MAPE       MASE
## Training set 25.22163 343.863 227.1699 0.08059942 0.7069541 0.06491041
##                   ACF1
## Training set 0.2081043

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.29 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.91 38246.40
## Jul 2020       37151.04 36005.74 38296.35
## Aug 2020       38564.65 37418.71 39710.59
## Sep 2020       38755.23 37609.03 39901.42
## Oct 2020       39779.03 38632.73 40925.33
## Nov 2020       38741.63 37595.29 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.41  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 Leches Saborizadas Hershey's", xlabs="Tiempo", 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.011298

3. Conlusiones

El modelo más adecuado para la serie es SARIMA, con un MAPE de 0.70%. En contraste, la regresión lineal presenta un MAPE de 2.01%, indicando un menor ajuste a los datos.

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

Mes y Año	Escenario Esperado	Escenario Pesimista	Esceneraio 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 2020	39779.02	38632.72	40925.32

ventas_anio<- read.csv("C:/Users/ferna/Desktop/ventas_por_anio.csv")

#ventas_anio<- read_csv("Desktop/Calses_8/R/DB/ventas_anio.csv")
ggplot(ventas_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="Miles de Doláres")

Nuestra recomendación sería realizar campañas publicitarias para aumentar el consumo de leche saborizada hershey’s para los meses de invierno que es cuando menos se consume. Para estos meses en cuestión, se puede ofrecer leche en polvo para consumir leche caliente.