Series de tiempo

Instalar paquetes y llamar librerias

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

Ejercicio 1 - Ventas semanales

INSTRUCCIONES: Modela la siguiente serie de tiempo y elige la mejor opción. Pronostica las siguientes 6 semanas.

semana <- c(1:12)
valor <- c(17,21,19,23,18,16,20,18,22,20,15,22)
df1 <- data.frame(semana, valor)

ts1 <- ts(valor, c(2025,1), frequency = 52)


# Modelo 1. Naive
naive1 <- naive(ts1, h=6)
summary(naive1)

## 
## Forecast method: Naive method
## 
## Model Information:
## Call: naive(y = ts1, h = 6) 
## 
## Residual sd: 4.0339 
## 
## Error measures:
##                     ME     RMSE      MAE       MPE     MAPE MASE       ACF1
## Training set 0.4545455 4.033947 3.727273 0.1082169 19.24431  NaN -0.4553872
## 
## Forecasts:
##          Point Forecast     Lo 80    Hi 80     Lo 95    Hi 95
## 2025.231             22 16.830289 27.16971 14.093609 29.90639
## 2025.250             22 14.688925 29.31108 10.818675 33.18132
## 2025.269             22 13.045798 30.95420  8.305730 35.69427
## 2025.288             22 11.660578 32.33942  6.187219 37.81278
## 2025.308             22 10.440175 33.55983  4.320773 39.67923
## 2025.327             22  9.336846 34.66315  2.633377 41.36662

# Modelo 2. Promedios móviles
ma1 <- ma(ts1, order = 3)
ma1_fc <- rep(tail(na.omit(ma1), 1), 6)
summary(ma1)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##    18.0    19.0    19.0    19.3    20.0    21.0       2

#Modelo 3. Promedios móviles ponderados (k=3)
pesos1 <- c(0.2, 0.3, 0.5)
wma1 <- stats::filter(df1$valor, filter = pesos1, sides = 1)
wma1_fc <- rep(tail(na.omit(wma1), 1), 6)
wma1

## Time Series:
## Start = 1 
## End = 12 
## Frequency = 1 
##  [1]   NA   NA 18.6 20.8 20.0 20.1 17.8 17.6 19.8 19.6 20.0 18.9

#Modelo 4. Suavizador exponencial (alfa = 0.2)
ses1 <- ses(ts1, alpha = 0.2, h = 6)
summary(ses1)

## 
## Forecast method: Simple exponential smoothing
## 
## Model Information:
## Simple exponential smoothing 
## 
## Call:
## ses(y = ts1, h = 6, alpha = 0.2)
## 
##   Smoothing parameters:
##     alpha = 0.2 
## 
##   Initial states:
##     l = 19.1774 
## 
##   sigma:  2.9273
## 
##      AIC     AICc      BIC 
## 57.40932 58.74266 58.37914 
## 
## Error measures:
##                      ME     RMSE      MAE       MPE     MAPE MASE       ACF1
## Training set 0.06549665 2.672288 2.312859 -1.479963 12.37329  NaN -0.3669082
## 
## Forecasts:
##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## 2025.231       19.33458 15.58304 23.08613 13.59709 25.07208
## 2025.250       19.33458 15.50875 23.16042 13.48347 25.18570
## 2025.269       19.33458 15.43587 23.23330 13.37201 25.29716
## 2025.288       19.33458 15.36432 23.30485 13.26259 25.40657
## 2025.308       19.33458 15.29405 23.37512 13.15512 25.51405
## 2025.327       19.33458 15.22497 23.44419 13.04948 25.61969

#Modelo 5. ARIMA
arima1 <- auto.arima(ts1)
summary(arima1)

## Series: ts1 
## ARIMA(0,0,0) with non-zero mean 
## 
## Coefficients:
##          mean
##       19.2500
## s.e.   0.6985
## 
## sigma^2 = 6.386:  log likelihood = -27.63
## AIC=59.26   AICc=60.59   BIC=60.23
## 
## Training set error measures:
##                        ME     RMSE      MAE       MPE     MAPE MASE      ACF1
## Training set 1.129763e-12 2.419539 2.083333 -1.662344 11.18529  NaN -0.363879

fc_arima1 <- forecast(arima1, h = 6)
fc_arima1

##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## 2025.231          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.250          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.269          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.288          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.308          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.327          19.25 16.01136 22.48864 14.29692 24.20308

# --- Selección del mejor modelo (comparando RMSE) ---
rmse_naive1 <- accuracy(naive1)[,"RMSE"]
rmse_ma1    <- accuracy(ma1_fc, tail(ts1,6))[,"RMSE"]
rmse_wma1   <- accuracy(wma1_fc, tail(ts1,6))[,"RMSE"]
rmse_ses1   <- accuracy(ses1)[,"RMSE"]
rmse_arima1 <- accuracy(fc_arima1)[,"RMSE"]

comparacion1 <- data.frame(
  Modelo = c("Naive", "Promedios móviles", "Promedios ponderados", "Suavizado exponencial", "ARIMA"),
  RMSE = c(rmse_naive1, rmse_ma1, rmse_wma1, rmse_ses1, rmse_arima1)
)
comparacion1

##                  Modelo     RMSE
## 1                 Naive 4.033947
## 2     Promedios móviles 2.483277
## 3  Promedios ponderados 2.505328
## 4 Suavizado exponencial 2.672288
## 5                 ARIMA 2.419539

mejor_modelo1 <- comparacion1$Modelo[which.min(comparacion1$RMSE)]
mejor_modelo1

## [1] "ARIMA"

#Pronóstico
pronostico1 <- switch(mejor_modelo1,
  "Naive" = forecast(naive1, h=6),
  "Promedios móviles" = ma1_fc,
  "Promedios ponderados" = wma1_fc,
  "Suavizado exponencial" = forecast(ses1, h=6),
  "ARIMA" = fc_arima1
)
pronostico1

##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## 2025.231          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.250          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.269          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.288          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.308          19.25 16.01136 22.48864 14.29692 24.20308
## 2025.327          19.25 16.01136 22.48864 14.29692 24.20308

plot(pronostico1)

#Conclusión
cat("El mejor modelo según el RMSE es:", mejor_modelo1, "\n")

## El mejor modelo según el RMSE es: ARIMA

cat("El RMSE obtenido fue de:", round(min(comparacion1$RMSE), 3), "\n")

## El RMSE obtenido fue de: 2.42

#El modelo ganador fue ARIMA(0,0,0) con media no nula, lo que en la práctica es equivalente a pronosticar usando el promedio histórico de las ventas (~19.2 unidades). Esto ocurre porque la serie no muestra una tendencia clara ni un patrón autorregresivo fuerte con solo 12 observaciones, más bien fluctúa alrededor de un valor constante. Por eso el pronóstico para las siguientes 6 semanas es una línea plana, y el intervalo de confianza es amplio, reflejando la alta variabilidad semanal (15 a 23) y la poca información disponible para hacer una predicción más precisa.

Ejercicio 2 - Hershey’s

Instrucciones: Modela la siguiente serie de tiempo y elige la mejor opción. Pronostica los siguientes 6 meses.

#file.choose()
df2_raw <- read.csv("/Users/carlalievanoespinosa/Desktop/business analytics/8vo semestre/hersheys.csv")

# El archivo tiene 3 pares de columnas (2017, 2018, 2019) que hay que unir
ventas2 <- c(df2_raw$Ventas, df2_raw$Ventas.1, df2_raw$Ventas.2)
ventas2 <- as.numeric(gsub(",", "", trimws(ventas2)))  # quita comas y espacios

df2 <- data.frame(mes = 1:length(ventas2), ventas = ventas2)
str(df2)

## 'data.frame':    36 obs. of  2 variables:
##  $ mes   : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ ventas: num  25521 23740 26254 25868 27073 ...

ts2 <- ts(df2$ventas, start = c(2017,1), frequency = 12)
ts2

##           Jan      Feb      Mar      Apr      May      Jun      Jul      Aug
## 2017 25520.51 23740.11 26253.58 25868.43 27072.87 27150.50 27067.10 28145.25
## 2018 28463.69 26996.11 29768.20 29292.51 29950.68 30099.17 30851.26 32271.76
## 2019 32496.44 31287.28 33376.02 32949.77 34004.11 33757.89 32927.30 34324.12
##           Sep      Oct      Nov      Dec
## 2017 27546.29 28400.37 27441.98 27852.47
## 2018 31940.74 32995.93 32197.12 31984.82
## 2019 35151.28 36133.07 34799.91 34846.17

# Modelo 1. Naive
naive2 <- naive(ts2, h=6)
summary(naive2)

## 
## Forecast method: Naive method
## 
## Model Information:
## Call: naive(y = ts2, h = 6) 
## 
## Residual sd: 1112.6435 
## 
## Error measures:
##                    ME     RMSE     MAE       MPE     MAPE      MASE       ACF1
## Training set 266.4474 1112.643 902.852 0.8162355 3.013137 0.2579764 -0.5648048
## 
## Forecasts:
##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2020       34846.17 33420.26 36272.08 32665.43 37026.91
## Feb 2020       34846.17 32829.63 36862.71 31762.14 37930.20
## Mar 2020       34846.17 32376.42 37315.92 31069.02 38623.32
## Apr 2020       34846.17 31994.35 37697.99 30484.69 39207.65
## May 2020       34846.17 31657.74 38034.60 29969.88 39722.46
## Jun 2020       34846.17 31353.42 38338.92 29504.47 40187.87

# Modelo 2. Promedios móviles
ma2 <- ma(ts2, order = 3)
ma2_fc <- rep(tail(na.omit(ma2), 1), 6)
summary(ma2)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   25171   27822   30687   30446   32504   35361       2

#Modelo 3. Promedios móviles ponderados (k=3)
pesos2 <- c(0.2, 0.3, 0.5)
wma2 <- stats::filter(df2$ventas, filter = pesos2, sides = 1)
wma2_fc <- rep(tail(na.omit(wma2), 1), 6)
wma2

## Time Series:
## Start = 1 
## End = 36 
## Frequency = 1 
##  [1]       NA       NA 25133.00 24919.82 26301.89 26486.18 27095.00 27324.43
##  [9] 27486.38 28016.59 27781.65 28003.27 27769.47 27864.56 28284.32 28287.02
## [17] 29661.99 29651.29 30175.34 30759.31 31495.31 32317.29 32308.57 32554.06
## [25] 32193.29 31998.80 32309.61 32246.40 33373.76 33427.70 33714.88 33621.96
## [33] 33791.14 34934.06 35375.54 35475.74

#Modelo 4. Suavizador exponencial (alfa = 0.2)
ses2 <- ses(ts2, alpha = 0.2, h = 6)
summary(ses2)

## 
## Forecast method: Simple exponential smoothing
## 
## Model Information:
## Simple exponential smoothing 
## 
## Call:
## ses(y = ts2, h = 6, alpha = 0.2)
## 
##   Smoothing parameters:
##     alpha = 0.2 
## 
##   Initial states:
##     l = 26303.9678 
## 
##   sigma:  1574.861
## 
##      AIC     AICc      BIC 
## 661.0074 661.3710 664.1744 
## 
## Error measures:
##                    ME     RMSE      MAE      MPE     MAPE      MASE      ACF1
## Training set 1111.747 1530.489 1335.458 3.458378 4.357769 0.3815872 0.3247296
## 
## Forecasts:
##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2020       34308.55 32290.28 36326.81 31221.88 37395.22
## Feb 2020       34308.55 32250.31 36366.78 31160.75 37456.34
## Mar 2020       34308.55 32211.10 36405.99 31100.78 37516.31
## Apr 2020       34308.55 32172.61 36444.48 31041.92 37575.17
## May 2020       34308.55 32134.81 36482.28 30984.10 37632.99
## Jun 2020       34308.55 32097.65 36519.44 30927.27 37689.82

#Modelo 5. ARIMA
arima2 <- auto.arima(ts2)
summary(arima2)

## Series: ts2 
## 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.5025
## 
## 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

fc_arima2 <- forecast(arima2, h = 6)
fc_arima2

##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2020       35498.90 34921.91 36075.88 34616.48 36381.32
## Feb 2020       34202.17 33517.65 34886.69 33155.29 35249.05
## Mar 2020       36703.01 35979.24 37426.78 35596.10 37809.92
## Apr 2020       36271.90 35532.73 37011.07 35141.44 37402.36
## May 2020       37121.98 36376.63 37867.33 35982.07 38261.90
## Jun 2020       37102.65 36354.80 37850.51 35958.91 38246.40

# --- Selección del mejor modelo (comparando RMSE) ---
rmse_naive2 <- accuracy(naive2)[,"RMSE"]
rmse_ma2    <- accuracy(ma2_fc, tail(ts2,6))[,"RMSE"]
rmse_wma2   <- accuracy(wma2_fc, tail(ts2,6))[,"RMSE"]
rmse_ses2   <- accuracy(ses2)[,"RMSE"]
rmse_arima2 <- accuracy(fc_arima2)[,"RMSE"]

comparacion2 <- data.frame(
  Modelo = c("Naive", "Promedios móviles", "Promedios ponderados", "Suavizado exponencial", "ARIMA"),
  RMSE = c(rmse_naive2, rmse_ma2, rmse_wma2, rmse_ses2, rmse_arima2)
)
comparacion2

##                  Modelo     RMSE
## 1                 Naive 1112.643
## 2     Promedios móviles 1115.979
## 3  Promedios ponderados 1239.036
## 4 Suavizado exponencial 1530.489
## 5                 ARIMA  343.863

mejor_modelo2 <- comparacion2$Modelo[which.min(comparacion2$RMSE)]
mejor_modelo2

## [1] "ARIMA"

#Pronóstico
pronostico2 <- switch(mejor_modelo2,
  "Naive" = forecast(naive2, h=6),
  "Promedios móviles" = ma2_fc,
  "Promedios ponderados" = wma2_fc,
  "Suavizado exponencial" = forecast(ses2, h=6),
  "ARIMA" = fc_arima2
)
pronostico2

##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2020       35498.90 34921.91 36075.88 34616.48 36381.32
## Feb 2020       34202.17 33517.65 34886.69 33155.29 35249.05
## Mar 2020       36703.01 35979.24 37426.78 35596.10 37809.92
## Apr 2020       36271.90 35532.73 37011.07 35141.44 37402.36
## May 2020       37121.98 36376.63 37867.33 35982.07 38261.90
## Jun 2020       37102.65 36354.80 37850.51 35958.91 38246.40

plot(pronostico2)

#Conclusión
cat("El mejor modelo según el RMSE es:", mejor_modelo2, "\n")

## El mejor modelo según el RMSE es: ARIMA

cat("El RMSE obtenido fue de:", round(min(comparacion2$RMSE), 3), "\n")

## El RMSE obtenido fue de: 343.863

#El modelo ganador fue ARIMA(1,0,0)(1,1,0)[12], el cual captura tanto la tendencia creciente de las ventas de Hershey's a lo largo de los 3 años (de ~25,000 a ~35,000) como el patrón estacional mensual que se repite cada 12 meses (los mismos altibajos que se ven en cada año). El pronóstico para los primeros 6 meses de 2020 mantiene esta tendencia al alza, proyectando ventas entre ~34,000 y ~37,000, con un intervalo de confianza razonablemente estrecho, reflejo de que, a diferencia del Ejercicio 1, aquí sí hay suficiente historia (36 meses) para que el modelo capture el comportamiento real de la serie con mayor certeza.

Ejercicio 3 - Vintage Restaurant

library(forecast)

# --- Datos ---
ventas <- c(242,235,232,178,184,140,145,152,110,130,152,206,   # Año 1
            263,238,247,193,193,149,157,161,122,130,167,230,   # Año 2
            282,255,265,205,210,160,166,174,126,148,173,235)   # Año 3

ts_vin <- ts(ventas, start = c(1,1), frequency = 12)

# 1. Gráfica de la serie de tiempo
plot(ts_vin, main = "Ventas mensuales - Vintage Restaurant", 
     ylab = "Ventas ($ miles)", xlab = "Año", type = "o")

# 2. Descomposición y análisis de estacionalidad
descomp <- decompose(ts_vin, type = "multiplicative")
plot(descomp)

indices_estacionales <- descomp$figure
names(indices_estacionales) <- month.abb
indices_estacionales

##       Jan       Feb       Mar       Apr       May       Jun       Jul       Aug 
## 1.4435875 1.2997005 1.3441203 1.0412017 1.0493867 0.8003807 0.8283067 0.8529746 
##       Sep       Oct       Nov       Dec 
## 0.6279872 0.7003228 0.8527594 1.1592718

# 3. Serie desestacionalizada
desestacionalizada <- ts_vin / rep(indices_estacionales, 3)
plot(desestacionalizada, main = "Serie desestacionalizada", type = "o")

# Tendencia sobre la serie desestacionalizada
t <- 1:36
tendencia <- lm(desestacionalizada ~ t)
summary(tendencia)

## 
## Call:
## lm(formula = desestacionalizada ~ t)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -6.1892 -2.2527 -0.4848  0.8131  9.4189 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 169.3494     1.0926  155.00   <2e-16 ***
## t             1.0213     0.0515   19.83   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 3.21 on 34 degrees of freedom
## Multiple R-squared:  0.9204, Adjusted R-squared:  0.9181 
## F-statistic: 393.3 on 1 and 34 DF,  p-value: < 2.2e-16

# 4. Pronóstico por descomposición (tendencia x índice estacional)
t4 <- 37:48
pred_tendencia <- coef(tendencia)[1] + coef(tendencia)[2]*t4
pronostico_descomp <- pred_tendencia * indices_estacionales
pronostico_descomp

##      Jan      Feb      Mar      Apr      May      Jun      Jul      Aug 
## 299.0209 270.5439 281.1630 218.8619 221.6542 169.8759 176.6490 182.7809 
##      Sep      Oct      Nov      Dec 
## 135.2105 151.5002 185.3475 253.1521

# 5. Pronóstico con regresión de variables ficticias (dummy)
mes <- factor(rep(month.abb, 3), levels = month.abb)
df_dummy <- data.frame(t = t, mes = mes, ventas = ventas)
modelo_dummy <- lm(ventas ~ t + mes, data = df_dummy)
summary(modelo_dummy)

## 
## Call:
## lm(formula = ventas ~ t + mes, data = df_dummy)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -8.1250 -1.9583  0.1667  2.2292  7.4583 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  249.10764    2.74567  90.727  < 2e-16 ***
## t              1.01736    0.07554  13.467 2.14e-12 ***
## mesFeb       -20.68403    3.62688  -5.703 8.30e-06 ***
## mesMar       -16.36806    3.62924  -4.510 0.000158 ***
## mesApr       -73.38542    3.63317 -20.199 3.90e-16 ***
## mesMay       -70.73611    3.63866 -19.440 8.97e-16 ***
## mesJun      -117.75347    3.64571 -32.299  < 2e-16 ***
## mesJul      -112.43750    3.65431 -30.768  < 2e-16 ***
## mesAug      -107.12153    3.66445 -29.233  < 2e-16 ***
## mesSep      -151.13889    3.67611 -41.114  < 2e-16 ***
## mesOct      -135.48958    3.68928 -36.725  < 2e-16 ***
## mesNov      -108.50694    3.70395 -29.295  < 2e-16 ***
## mesDec       -49.85764    3.72009 -13.402 2.36e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4.441 on 23 degrees of freedom
## Multiple R-squared:  0.9942, Adjusted R-squared:  0.9911 
## F-statistic:   327 on 12 and 23 DF,  p-value: < 2.2e-16

nuevo <- data.frame(t = t4, mes = factor(month.abb, levels = month.abb))
pronostico_dummy <- predict(modelo_dummy, newdata = nuevo)
pronostico_dummy

##        1        2        3        4        5        6        7        8 
## 286.7500 267.0833 272.4167 216.4167 220.0833 174.0833 180.4167 186.7500 
##        9       10       11       12 
## 143.7500 160.4167 188.4167 248.0833

# Error de pronóstico para enero del año 4 (venta real = 295)
error_descomp <- 295 - pronostico_descomp[1]
error_dummy   <- 295 - pronostico_dummy[1]
error_descomp

##       Jan 
## -4.020918

error_dummy

##    1 
## 8.25

Gráfica de la serie de tiempo

La serie muestra un patrón estacional muy marcado que se repite cada 12 meses, combinado con una tendencia ligeramente creciente año con año (las ventas de cada mes son consistentemente mayores que las del mismo mes del año anterior).

Análisis de estacionalidad

library(knitr)

tabla_estacional <- data.frame(
  Mes = month.abb,
  Indice_Estacional = round(as.numeric(indices_estacionales), 3)
)

kable(tabla_estacional, 
      col.names = c("Mes", "Índice Estacional"),
      caption = "Índices estacionales - Vintage Restaurant",
      align = "c")

Índices estacionales - Vintage Restaurant

Mes	Índice Estacional
Jan	1.444
Feb	1.300
Mar	1.344
Apr	1.041
May	1.049
Jun	0.800
Jul	0.828
Aug	0.853
Sep	0.628
Oct	0.700
Nov	0.853
Dec	1.159

Enero, febrero y marzo tienen ventas ~30-44% por encima del promedio, mientras que septiembre cae ~37% por debajo. Esto tiene sentido intuitivo: Captiva Island, Florida, es un destino turístico de temporada invernal (los “snowbirds” llegan de diciembre a marzo), mientras que septiembre coincide con el verano, el calor y la temporada de huracanes, cuando el turismo cae drásticamente.

Serie desestacionalizada

Al remover el efecto estacional, se observa una tendencia lineal creciente clara: las ventas desestacionalizadas suben de ~168 (mes 1) a ~203 (mes 36), con una pendiente estimada de ~1.02 unidades por mes, es decir, un crecimiento subyacente constante del negocio, sin importar la temporada.

Tabla 2: Pronóstico por descomposición (Año 4)

tabla_descomp <- data.frame(
  Mes = month.abb,
  Pronostico = round(as.numeric(pronostico_descomp), 2)
)

kable(tabla_descomp,
      col.names = c("Mes", "Pronóstico ($ miles)"),
      caption = "Pronóstico Año 4 - Método de Descomposición",
      align = "c")

Pronóstico Año 4 - Método de Descomposición

Mes	Pronóstico ($ miles)
Jan	299.02
Feb	270.54
Mar	281.16
Apr	218.86
May	221.65
Jun	169.88
Jul	176.65
Aug	182.78
Sep	135.21
Oct	151.50
Nov	185.35
Dec	253.15

Pronóstico por regresión con variables dummy (Año 4)

tabla_dummy <- data.frame(
  Mes = month.abb,
  Pronostico = round(as.numeric(pronostico_dummy), 2)
)

kable(tabla_dummy,
      col.names = c("Mes", "Pronóstico ($ miles)"),
      caption = "Pronóstico Año 4 - Regresión con Variables Ficticias",
      align = "c")

Pronóstico Año 4 - Regresión con Variables Ficticias

Mes	Pronóstico ($ miles)
Jan	286.75
Feb	267.08
Mar	272.42
Apr	216.42
May	220.08
Jun	174.08
Jul	180.42
Aug	186.75
Sep	143.75
Oct	160.42
Nov	188.42
Dec	248.08

Comparación de ambos métodos

tabla_comparacion <- data.frame(
  Mes = month.abb,
  Descomposicion = round(as.numeric(pronostico_descomp), 2),
  Regresion_Dummy = round(as.numeric(pronostico_dummy), 2)
)

kable(tabla_comparacion,
      col.names = c("Mes", "Descomposición ($ miles)", "Regresión Dummy ($ miles)"),
      caption = "Comparación de pronósticos - Año 4",
      align = "c")

Comparación de pronósticos - Año 4

Mes	Descomposición ($ miles)	Regresión Dummy ($ miles)
Jan	299.02	286.75
Feb	270.54	267.08
Mar	281.16	272.42
Apr	218.86	216.42
May	221.65	220.08
Jun	169.88	174.08
Jul	176.65	180.42
Aug	182.78	186.75
Sep	135.21	143.75
Oct	151.50	160.42
Nov	185.35	188.42
Dec	253.15	248.08

Error de pronóstico (Enero Año 4)

venta_real_ene4 <- 295

tabla_error <- data.frame(
  Metodo = c("Descomposición", "Regresión con Dummy"),
  Pronostico = c(round(pronostico_descomp[1], 2), round(pronostico_dummy[1], 2)),
  Real = venta_real_ene4,
  Error = c(round(venta_real_ene4 - pronostico_descomp[1], 2), 
            round(venta_real_ene4 - pronostico_dummy[1], 2)),
  Error_Porcentual = c(paste0(round((venta_real_ene4 - pronostico_descomp[1])/venta_real_ene4*100, 2), "%"),
                       paste0(round((venta_real_ene4 - pronostico_dummy[1])/venta_real_ene4*100, 2), "%"))
)

kable(tabla_error,
      col.names = c("Método", "Pronóstico", "Real", "Error", "Error %"),
      caption = "Error de pronóstico - Enero Año 4",
      align = "c")

Error de pronóstico - Enero Año 4

	Método	Pronóstico	Real	Error	Error %
Jan	Descomposición	299.02	295	-4.02	-1.36%
1	Regresión con Dummy	286.75	295	8.25	2.8%

El modelo de regresión con dummies tiene un R² de 0.994, lo que indica un ajuste excelente. Ambos métodos dan resultados muy similares y consistentes entre sí.

Error de pronóstico (enero del Año 4, venta real = $295,000)

Método de descomposición: pronóstico = $299,020 → error = –$4,020 (–1.4%) Método de regresión con dummies: pronóstico = $286,750 → error = +$8,250 (+2.8%)

Ambos errores son relativamente pequeños (menores al 3%), por lo que no deberían generar mayor confusión para Karen, son diferencias normales dentro del margen esperado de un buen modelo de pronóstico.

Ejercicio 4: Carlson Department store

library(knitr)

# --- Datos históricos pre-huracán (36 meses: Sep Año1 - Ago Año4) ---
carlson <- c(1.71,1.90,2.74,4.20,                                       # Año1 Sep-Dic
             1.45,1.80,2.03,1.99,2.32,2.20,2.13,2.43,1.90,2.13,2.56,4.16, # Año2
             2.31,1.89,2.02,2.23,2.39,2.14,2.27,2.21,1.89,2.29,2.83,4.04, # Año3
             2.31,1.99,2.42,2.45,2.57,2.42,2.40,2.50)                    # Año4 Ene-Ago

condado <- c(55.80,56.40,71.40,117.60,
             46.80,48.00,60.00,57.60,61.80,58.20,56.40,63.00,57.60,53.40,71.40,114.00,
             46.80,48.60,59.40,58.20,60.60,55.20,51.00,58.80,49.80,54.60,65.40,102.00,
             43.80,45.60,57.60,53.40,56.40,52.80,54.00,60.60)

# Ventas reales del condado durante el cierre (Sep-Dic Año4)
condado_real_cierre <- c(47.40, 54.60, 67.80, 100.20)

ts_carlson <- ts(carlson, start = c(1,9), frequency = 12)
ts_condado <- ts(condado, start = c(1,9), frequency = 12)


# --- Descomposición multiplicativa ---
descomp_carlson <- decompose(ts_carlson, type = "multiplicative")
descomp_condado <- decompose(ts_condado, type = "multiplicative")

indices_carlson <- descomp_carlson$figure
indices_condado <- descomp_condado$figure
names(indices_carlson) <- month.abb[c(9:12,1:8)]
names(indices_condado) <- month.abb[c(9:12,1:8)]

# --- Desestacionalizar y ajustar tendencia ---
t <- 1:36
deseason_carlson <- ts_carlson / rep(descomp_carlson$figure, 3)
deseason_condado  <- ts_condado / rep(descomp_condado$figure, 3)

tend_carlson <- lm(as.numeric(deseason_carlson) ~ t)
tend_condado <- lm(as.numeric(deseason_condado) ~ t)

# --- Pronóstico Sep-Dic Año4 (meses 37-40) SIN huracán ---
t_f <- 37:40
indices_f <- descomp_carlson$figure[9:12]  # Sep, Oct, Nov, Dic
indices_f_condado <- descomp_condado$figure[9:12]

pred_carlson <- (coef(tend_carlson)[1] + coef(tend_carlson)[2]*t_f) * indices_f
pred_condado <- (coef(tend_condado)[1] + coef(tend_condado)[2]*t_f) * indices_f_condado

pred_carlson

## [1] 2.632104 2.440441 2.467124 2.591732

pred_condado

## [1] 57.10517 53.12090 50.44835 57.16943

# --- 1. Ventas estimadas de Carlson sin huracán (pérdida) ---
perdida_carlson <- pred_carlson  # ventas reales = 0 (tienda cerrada)
sum(perdida_carlson)

## [1] 10.1314

# --- 2. Ventas estimadas del condado sin huracán ---
sum(pred_condado)

## [1] 217.8439

# --- 3. Comparación condado: real vs. pronóstico (exceso por huracán) ---
exceso <- condado_real_cierre - pred_condado
tabla_exceso <- data.frame(
  Mes = c("Sep","Oct","Nov","Dic"),
  Pronostico_sin_huracan = round(as.numeric(pred_condado), 2),
  Real = condado_real_cierre,
  Exceso = round(exceso, 2)
)
tabla_exceso

##   Mes Pronostico_sin_huracan  Real Exceso
## 1 Sep                  57.11  47.4  -9.71
## 2 Oct                  53.12  54.6   1.48
## 3 Nov                  50.45  67.8  17.35
## 4 Dic                  57.17 100.2  43.03

sum(exceso)

## [1] 52.15614

kable(data.frame(Mes = c("Sep","Oct","Nov","Dic"),
                  Pronostico = round(as.numeric(pred_carlson), 2)),
      col.names = c("Mes", "Ventas estimadas sin huracán ($ millones)"),
      caption = "Pronóstico de ventas de Carlson (sin huracán) - Sep a Dic Año 4",
      align = "c")

Pronóstico de ventas de Carlson (sin huracán) - Sep a Dic Año 4

Mes	Ventas estimadas sin huracán ($ millones)
Sep	2.63
Oct	2.44
Nov	2.47
Dic	2.59

kable(tabla_exceso,
      col.names = c("Mes", "Pronóstico sin huracán", "Real", "Exceso"),
      caption = "Comparación de ventas reales vs. pronosticadas - Condado",
      align = "c")

Comparación de ventas reales vs. pronosticadas - Condado

Mes	Pronóstico sin huracán	Real	Exceso
Sep	57.11	47.4	-9.71
Oct	53.12	54.6	1.48
Nov	50.45	67.8	17.35
Dic	57.17	100.2	43.03