ACTIVIDAD 2

Ejercicio en clase_ Población

Instalar paquetes y llamar librerías

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

Importar base de datos

#file.choose()
poblacion<- read.csv("D:\\Descargas\\population.csv")

Entender un poco 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 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 = 1950, frequency=1) 
#SERIE DE TIEMPO ANUAL (CADA AÑO TENEMOS UN REGISTRO DE LA POBLACIÓN)

#TS_TEXAS <- ts(poblacion_texas$population, start = C(1900, 4), frequency=4) 
#SERIE DE TIEMPO TRIMESRTAL COMENZANDO EN EL TRIMESTRE 4 (OCT-NOV-DIC)

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)
plot(pronostico_texas, main="Población en Texas")

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("D:\\Descargas\\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 librerías

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

Importar la base de datos

ventas <- read.csv("C:\\Users\\LuisD\\Documents\\OCTAVO SEMESTRE\\Generación de escenarios\\Módulo 1\\Ventas_Históricas_Lechitas.csv")
#file.choose()

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 Dólares")

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_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="Tiempo", y="Niles de Dólares")

2. Modelo de 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_año <- data.frame(mes = 37:48)
prediccion_regresion <- predict(regresion_ventas, siguiente_año)
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 = "Tiempo", ylab = "Miles de Dólares") + abline(regresion_ventas, col="blue") + points(prediccion_regresion, col="red")

## integer(0)

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

## [1] 2.011298

3. Conclusiones

El mejor modelo que se adapta a la serie es el SARIMA con unMAPE de 0.71%, comparado con la Regersió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.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 |

ventas_por_anio <- read.csv("C:\\Users\\LuisD\\Documents\\OCTAVO SEMESTRE\\Generación de escenarios\\Módulo 1\\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 Dólares")

Nuestra reocmentación sería realiar campañas publicitarias para aumentar el comsumo de leche daborizada Hershey’s en el primer semestre del año