Actividad 2

Ejercicio en clase : Poblacion

Instalar paquetes y llamar librerias

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

Instalar base de datos

poblacion <- read.csv("C:\\Users\\Luis Mendoza\\Downloads\\population.csv")
#poblacion

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 = "Anio", y="Poblacion")

ts_texas <- ts(poblacion_texas$population,start=1900,frequency=1) #Serie de tiempo Anual
# ts_texas <- ts(poblacion_texas$population,start=(1900,4),frequency=4) #Serie de tiempo trimestral
# ts_texas <- ts(poblacion_texas$population,start=(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 = 20)
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
## 2030       33482027 31894047 35070007
## 2031       33890382 32143561 35637204
## 2032       34298738 32388674 36208801
## 2033       34707093 32629456 36784730
## 2034       35115449 32865983 37364914
## 2035       35523804 33098330 37949278
## 2036       35932160 33326573 38537746
## 2037       36340515 33550788 39130242
## 2038       36748871 33771046 39726695
## 2039       37157226 33987418 40327034

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

## Crear un mapa

names(poblacion)

## [1] "state"      "year"       "population"

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

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\\Luis Mendoza\\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

Crear un mapa

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)

## Crear un mapa de EUA por década, con un gradiente verde-rojo de la población pos estado, desde 1950 hasta 2050

# Cargar librerías necesarias
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)
library(scales)

## 
## Adjuntando el paquete: '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 se encuentran en rojo y los menos poblados se representan 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\\Luis Mendoza\\Downloads\\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:

ventas_anio<- read.csv("C:\\Users\\Luis Mendoza\\Downloads\\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")

Sugerimos llevar a cabo campañas publicitarias dirigidas a aumentar el consumo de leche saborizada Hershey’s durante los meses de invierno, que es cuando la demanda disminuye. Durante este periodo, también se podría promover la leche en polvo, ideal para preparar leche caliente.