Actividad 2

Ejercicio en Clase: Población

Instalar paquetes y llamar librerias

#install.packages("forecast")
library(forecast)

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

#install.packages("tidyverse")
library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.2     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.2     ✔ tidyr     1.3.0
## ✔ purrr     1.0.1

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

#install.packages("ggplot2")
library(ggplot2)
#install.packages("dplyr")
library(dplyr)

Importar la base de datos

#file.choose()
poblacion <- read.csv("C:\\Users\\Diego Pérez\\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="Población 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 trimestral
#ts_texas <- ts(poblacion_texas$population, start = c(1900, 8), frequency=) #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_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

## Intalar paquetes y llamar librerias

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

## Warning: package 'maps' was built under R version 4.3.3

## 
## Attaching package: 'maps'

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

Importar la base de datos

#file.choose()
poblacion <- read.csv("C:\\Users\\Diego Pérez\\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="Población de Texas", x ="Año", y="Población")

ts_texas <- ts(poblacion_texas$population, start = 1950, 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=) #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_texas

##      Point Forecast    Lo 95    Hi 95
## 2070       29398472 29199487 29597457
## 2071       29806827 29463665 30149990
## 2072       30215183 29742956 30687410
## 2073       30623538 30024100 31222977
## 2074       31031894 30303359 31760429
## 2075       31440249 30579246 32301253
## 2076       31848605 30851090 32846119
## 2077       32256960 31118581 33395339
## 2078       32665316 31381587 33949044
## 2079       33073671 31640070 34507272

plot(pronostico_texas, main = "Población en Texas")

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)

Actividad Crear un Mapa

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

Instalar y cargar las librerías necesarias para análisis y visualización

# install.packages(c("dplyr", "ggplot2", "forecast", "maps"))
library(dplyr)
library(ggplot2)
library(forecast)
library(maps)

Importar la base de datos de población

poblacion <- read.csv("C:\\Users\\Diego Pérez\\Downloads\\population.csv")

Proyectar la población estatal hasta 2050 y combinar con datos originales

# Integración de pronósticos con la base de datos inicial
# Crear un dataset ampliado que parte de la base de datos original
poblacion_extendida <- poblacion

# Extraer la lista de estados únicos presentes en los datos
estados <- unique(poblacion$state)

# Modelar y pronosticar la población de cada estado hasta el año 2050
for(st in estados){
  
  # Filtrar y organizar los datos por año para cada estado
  datos_st <- poblacion %>%
    filter(state == st) %>%
    arrange(year)
  
  # Identificar el último año disponible en la serie histórica
  ultimo_anio <- max(datos_st$year)
  
  # Generar la serie de tiempo anual para la población del estado
  ts_st <- ts(datos_st$population,
              start = min(datos_st$year),
              end   = ultimo_anio,
              frequency = 1)  # Datos anuales
  
  # Ajustar un modelo ARIMA de manera automática para el estado
  modelo_st <- auto.arima(ts_st)
  
  # Calcular el horizonte de pronóstico necesario
  # (se genera forecast solo si faltan años para llegar a 2050)
  h_years <- 2050 - ultimo_anio
  
  if(h_years > 0){
    # Generar el pronóstico para el periodo faltante
    pronostico <- forecast(modelo_st, h = h_years)
    
    # Crear un dataframe con las proyecciones generadas
    anios_pronostico <- (ultimo_anio + 1):2050
    poblacion_pronosticada <- as.numeric(pronostico$mean)
    
    df_forecast <- data.frame(
      state = st,
      year  = anios_pronostico,
      population = poblacion_pronosticada
    )
    
    # Incorporar las proyecciones al dataset extendido
    poblacion_extendida <- rbind(poblacion_extendida, df_forecast)
  }
}

Definir una función para visualizar el mapa de población por año

plot_map <- function(year) {
  
  # Filtrar el dataset para el año especificado
  data_year <- poblacion_extendida %>%
    filter(year == !!year)
  
  # Cargar la información geográfica de los estados de EE.UU.
  states_map <- map_data("state")
  
  # Relacionar las abreviaturas estatales con los nombres completos en minúsculas
  # Utilizando los vectores auxiliares state.abb y state.name
  data_year <- data_year %>%
    mutate(region = tolower(state.name[match(state, state.abb)])) %>%
    right_join(states_map, by = "region")
  
  # Generar el mapa temático por población
  ggplot(data_year, aes(x = long, y = lat, group = group, fill = population)) +
    geom_polygon(color = "black") +
    # Aplicar un gradiente de color verde (bajo) a rojo (alto)
    scale_fill_gradient(
      low = "green",   # Representa la menor población
      high = "red",    # Indica la mayor población
      name = "Población"
    ) +
    labs(
      title = paste("Población por Estado en", year)
    ) +
    theme_void() +
    theme(
      legend.position = "right",
      plot.title = element_text(size = 16, face = "bold")
    )
}

Visualizar la evolución demográfica cada década (1950 - 2050)

for(year in seq(1950, 2050, by = 10)) {
  print(plot_map(year))
}

Actividad 2. Leche Saborizada Hershey’s

Instalar paquetes y llamar librerias

install.packages("forecast")

## Warning: package 'forecast' is in use and will not be installed

library(forecast)
install.packages("tidyverse")

## Warning: package 'tidyverse' is in use and will not be installed

library(tidyverse)
install.packages("ggplot2")

## Warning: package 'ggplot2' is in use and will not be installed

library(ggplot2)

Importar la base de datos

#file.choose()
ventas <- read.csv("C:\\Users\\Diego Pérez\\Downloads\\Ventas_Históricas_Lechitas.csv")

1. Modelo AUTO.ARIMA

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_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 = "Pronostico de ventas 2020 de leche Sabpoorizada Hershey's", x="Tiempo", y="Miles de dolares")

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="Pronostico de ventas 2020 de leche Saborizada Hershey's", xlab="Tiempo", ylab="Miles de dolares") +
abline(regresion_ventas, col="blue") +
points(siguiente_anio$mes, prediccion_Regresion, col="red")

## integer(0)

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

## [1] 2.011297

3. Conclusión

El mejor modelo que se adapta a la serie es el SARIMA con un MAPE de 0.70, comparado con la Regresión 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 Esperado	Escenario Pesimista	Escenario 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
Nov 2020	38741.63	37595.28	39887.97
Dec 2020	38645.86	37499.50	39792.22

ventas_por_anio <- read.csv("C:\\Users\\Diego Pérez\\Downloads\\ventas_por_anio.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= "Miles de dolares")

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