Series de Tiempo

Instalar paquetes y llamar librerías

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

Ejercicio 1. Ventas Semanales

INSTRUCCIONES: Modela la siguiente Serie de Tiempo y elige la mejor opción. Pronostica las sigueintes 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 con menor MAPE es el mas adecuado.

# Modelo 2. Promedio Móvil (k = 3)
ma1 <- ma(ts1, order = 3)
ma1

## Time Series:
## Start = c(2025, 1) 
## End = c(2025, 12) 
## Frequency = 52 
##  [1] NA 19 21 20 19 18 18 20 20 19 19 NA

# Modelo 3. Promedio Móvil Ponderado
# Pesos: 3/6, 2/6 y 1/6
wma1 <- weighted.mean(
  x = tail(valor, 3),
  w = c(1/6, 2/6, 3/6)
)

wma1

## [1] 19.33333

# Modelo 4. Suavizador Exponencial (alpha = 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 -3.552714e-15 2.419539 2.083333 -1.662344 11.18529  NaN -0.363879

# Pronóstico ARIMA
forecast_arima1 <- forecast(arima1, h = 6)
forecast_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

# Comparación de modelos
accuracy(naive1)

##                     ME     RMSE      MAE       MPE     MAPE MASE       ACF1
## Training set 0.4545455 4.033947 3.727273 0.1082169 19.24431  NaN -0.4553872

accuracy(ses1)

##                      ME     RMSE      MAE       MPE     MAPE MASE       ACF1
## Training set 0.06549665 2.672288 2.312859 -1.479963 12.37329  NaN -0.3669082

accuracy(forecast_arima1)

##                         ME     RMSE      MAE       MPE     MAPE MASE      ACF1
## Training set -3.552714e-15 2.419539 2.083333 -1.662344 11.18529  NaN -0.363879

# Tabla con el Resumen de los Resultados

resultados1 <- data.frame(
  Modelo = c("Naive", "Suavizador Exponencial", "ARIMA"),
  MAPE = c(19.24431, 12.37329, 11.18529)
)

resultados1

##                   Modelo     MAPE
## 1                  Naive 19.24431
## 2 Suavizador Exponencial 12.37329
## 3                  ARIMA 11.18529

# Conclusión Método ARE

# Afirmación:
# El modelo ARIMA es el más adecuado para realizar el pronóstico de las siguientes 6 semanas.

# Razón:
# Presenta el menor MAPE entre los modelos evaluados, lo que indica
# que tiene el menor error porcentual promedio.

# Evidencia:
# ARIMA obtuvo un MAPE de 11.19%, menor al 12.37% del Suavizador
# Exponencial y al 19.24% del modelo Naive.

# Pronóstico de las siguientes 6 semanas

pronostico1 <- forecast(arima1, h = 6)

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

autoplot(pronostico1)

CONCLUSIÓ DEL PRONÓSTICO:

Afirmación: El modelo ARIMA pronostica que las ventas se mantendrán estables en aproximadamente 19.25 unidades por semana durante las próximas 6 semanas.

Razón: Las seis predicciones puntuales son iguales, lo que indica que el modelo no espera una tendencia de crecimiento o disminución en el corto plazo.

Evidencia: El pronóstico para cada una de las seis semanas es de 19.25 ventas, con un intervalo de predicción del 80% entre 16.01 y 22.49, y del 95% entre 14.30 y 24.20. Por lo tanto, se espera que las ventas permanezcan alrededor de 19 unidades semanales, aunque existe variabilidad en los resultados posibles.

Ejercicio 2. Hershey’s

INSTRUCCIONES: Modela la siguiente Serie de Tiempo y elige la mejor opción. Pronostica las sigueintes 6 semanas.

# Cargar datos
df2 <- read_csv("/Users/sharontorres/Downloads/Act2/Ventas_Históricas_Lechitas.xlsx - Hoja1.csv")

## Rows: 36 Columns: 2
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (1): Mes
## num (1): Ventas
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

# Revisar los datos
head(df2)

## # A tibble: 6 × 2
##   Mes    Ventas
##   <chr>   <dbl>
## 1 ene-17 25521.
## 2 feb-17 23740.
## 3 mar-17 26254.
## 4 abr-17 25868.
## 5 may-17 27073.
## 6 jun-17 27150.

names(df2)

## [1] "Mes"    "Ventas"

# Crear la serie de tiempo mensual
ts2 <- ts(
  df2$Ventas,
  start = c(2017, 1),
  frequency = 12
)

# 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. Promedio Móvil (k = 3)
ma2 <- ma(ts2, order = 3)
ma2

##           Jan      Feb      Mar      Apr      May      Jun      Jul      Aug
## 2017       NA 25171.40 25287.37 26398.29 26697.27 27096.82 27454.28 27586.21
## 2018 27770.76 28409.33 28685.61 29670.46 29780.79 30300.37 31074.06 31687.92
## 2019 31922.85 32386.58 32537.69 33443.30 33570.59 33563.10 33669.77 34134.23
##           Sep      Oct      Nov      Dec
## 2017 28030.64 27796.21 27898.27 27919.38
## 2018 32402.81 32377.93 32392.62 32226.13
## 2019 35202.82 35361.42 35259.72       NA

# Modelo 3. Promedio Móvil Ponderado
# Pesos: 3/6, 2/6 y 1/6
wma2 <- weighted.mean(
  x = tail(df2$Ventas, 3),
  w = c(1/6, 2/6, 3/6)
)

wma2

## [1] 35045.23

# Modelo 4. Suavizador Exponencial (alpha = 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

# Pronóstico ARIMA
forecast_arima2 <- forecast(arima2, h = 6)
forecast_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

# Comparación de modelos
accuracy(naive2)

##                    ME     RMSE     MAE       MPE     MAPE      MASE       ACF1
## Training set 266.4474 1112.643 902.852 0.8162355 3.013137 0.2579764 -0.5648048

accuracy(ses2)

##                    ME     RMSE      MAE      MPE     MAPE      MASE      ACF1
## Training set 1111.747 1530.489 1335.458 3.458378 4.357769 0.3815872 0.3247296

accuracy(forecast_arima2)

##                    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

# Tabla con el Resumen de los Resultados

resultados2 <- data.frame(
  Modelo = c("Naive", "Suavizador Exponencial", "ARIMA"),
  MAPE = c(
    accuracy(naive2)["Training set", "MAPE"],
    accuracy(ses2)["Training set", "MAPE"],
    accuracy(forecast_arima2)["Training set", "MAPE"]
  )
)

resultados2

##                   Modelo      MAPE
## 1                  Naive 3.0131374
## 2 Suavizador Exponencial 4.3577690
## 3                  ARIMA 0.7069541

# Conclusión Método ARE

# Afirmación:
# El modelo ARIMA es el más adecuado para realizar el pronóstico
# de las siguientes 6 semanas de ventas de Lechitas Hershey's.

# Razón:
# ARIMA presenta el menor MAPE entre los tres modelos evaluados,
# por lo que genera el menor error porcentual promedio y ofrece
# un pronóstico más preciso para esta serie de tiempo.

# Evidencia:
# ARIMA obtuvo un MAPE de 0.71%, mientras que el modelo Naive
# obtuvo un MAPE de 3.01% y el Suavizador Exponencial un MAPE
# de 4.36%. Por lo tanto, ARIMA presenta el mejor desempeño
# predictivo entre los modelos analizados.

# Pronóstico de los siguientes 6 meses

pronostico2 <- forecast(arima2, h = 6)

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

autoplot(pronostico2)

CONCLUSIÓ DEL PRONÓSTICO:

Afirmación: Las ventas proyectadas para los próximos seis meses muestran un panorama positivo, ya que, aunque se espera una pequeña disminución en febrero, posteriormente las ventas vuelven a crecer y se mantienen en niveles altos durante los últimos meses del periodo.

Razón: El comportamiento esperado indica que la disminución de febrero sería temporal. A partir de marzo las ventas comienzan a recuperarse, por lo que la empresa podría prepararse con anticipación para los meses en los que se espera una mayor cantidad de ventas. Esto ayudaría a tener suficiente producto disponible y evitar perder ventas por falta de inventario.

Evidencia: Para enero se esperan 35,498.90 ventas, mientras que en febrero se proyectan 34,202.17. Después, las ventas aumentan a 36,703.01 en marzo, 36,271.90 en abril y alcanzan su punto más alto en mayo con 37,121.98 ventas. En junio se mantienen prácticamente al mismo nivel, con 37,102.65 ventas.

Desde el punto de vista del negocio, estos resultados indican que Hershey’s debería prepararse especialmente para los meses de mayo y junio, asegurando que haya suficiente producto disponible y ajustando sus pedidos y producción de acuerdo con la demanda esperada. También podría aprovechar este crecimiento para planear promociones o campañas comerciales en los meses con mayor potencial de ventas. En general, el pronóstico refleja una oportunidad de crecimiento en las ventas, por lo que anticiparse a este comportamiento permitiría aprovechar mejor la demanda y evitar quedarse sin producto.

Ejercicio 3. Vintage Restaurant

INSTRUCCIONES: Elabore un análisis de los datos de las ventas de Vintage Restaurant. Prepare un informe para Karen que resuma sus hallazgos, pronósticos y recomendaciones.

# Datos de ventas mensuales
# Los valores están expresados en miles de dólares

Año1 <- c(242, 235, 232, 178, 184, 140, 145, 152, 110, 130, 152, 206)

Año2 <- c(263, 238, 247, 193, 193, 149, 157, 161, 122, 130, 167, 230)

Año3 <- c(282, 255, 265, 205, 210, 160, 166, 174, 126, 148, 173, 235)

ventas <- c(Año1, Año2, Año3)

# Crear la serie de tiempo mensual
ts3 <- ts(
  ventas,
  start = c(2017, 1),
  frequency = 12
)

ts3

##      Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
## 2017 242 235 232 178 184 140 145 152 110 130 152 206
## 2018 263 238 247 193 193 149 157 161 122 130 167 230
## 2019 282 255 265 205 210 160 166 174 126 148 173 235

autoplot(ts3) +
  ggtitle("Ventas mensuales de Vintage Restaurant") +
  xlab("Año") +
  ylab("Ventas (miles de dólares)")

descomp <- decompose(ts3)

descomp

## $x
##      Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
## 2017 242 235 232 178 184 140 145 152 110 130 152 206
## 2018 263 238 247 193 193 149 157 161 122 130 167 230
## 2019 282 255 265 205 210 160 166 174 126 148 173 235
## 
## $seasonal
##             Jan        Feb        Mar        Apr        May        Jun
## 2017  83.324653  56.428819  65.137153   7.428819   9.116319 -38.925347
## 2018  83.324653  56.428819  65.137153   7.428819   9.116319 -38.925347
## 2019  83.324653  56.428819  65.137153   7.428819   9.116319 -38.925347
##             Jul        Aug        Sep        Oct        Nov        Dec
## 2017 -31.654514 -27.404514 -69.008681 -56.258681 -27.862847  29.678819
## 2018 -31.654514 -27.404514 -69.008681 -56.258681 -27.862847  29.678819
## 2019 -31.654514 -27.404514 -69.008681 -56.258681 -27.862847  29.678819
## 
## $trend
##           Jan      Feb      Mar      Apr      May      Jun      Jul      Aug
## 2017       NA       NA       NA       NA       NA       NA 176.3750 177.3750
## 2018 182.0000 182.8750 183.7500 184.2500 184.8750 186.5000 188.2917 189.7917
## 2019 195.7083 196.6250 197.3333 198.2500 199.2500 199.7083       NA       NA
##           Sep      Oct      Nov      Dec
## 2017 178.1250 179.3750 180.3750 181.1250
## 2018 191.2500 192.5000 193.7083 194.8750
## 2019       NA       NA       NA       NA
## 
## $random
##             Jan        Feb        Mar        Apr        May        Jun
## 2017         NA         NA         NA         NA         NA         NA
## 2018 -2.3246528 -1.3038194 -1.8871528  1.3211806 -0.9913194  1.4253472
## 2019  2.9670139  1.9461806  2.5295139 -0.6788194  1.6336806 -0.7829861
##             Jul        Aug        Sep        Oct        Nov        Dec
## 2017  0.2795139  2.0295139  0.8836806  6.8836806 -0.5121528 -4.8038194
## 2018  0.3628472 -1.3871528 -0.2413194 -6.2413194  1.1545139  5.4461806
## 2019         NA         NA         NA         NA         NA         NA
## 
## $figure
##  [1]  83.324653  56.428819  65.137153   7.428819   9.116319 -38.925347
##  [7] -31.654514 -27.404514 -69.008681 -56.258681 -27.862847  29.678819
## 
## $type
## [1] "additive"
## 
## attr(,"class")
## [1] "decomposed.ts"

autoplot(descomp)

indices_estacionales <- data.frame(
  Mes = month.abb,
  Indice_Estacional = round(descomp$figure, 4)
)

indices_estacionales

##    Mes Indice_Estacional
## 1  Jan           83.3247
## 2  Feb           56.4288
## 3  Mar           65.1372
## 4  Apr            7.4288
## 5  May            9.1163
## 6  Jun          -38.9253
## 7  Jul          -31.6545
## 8  Aug          -27.4045
## 9  Sep          -69.0087
## 10 Oct          -56.2587
## 11 Nov          -27.8628
## 12 Dec           29.6788

# Desestacionalizar la serie de tiempo
ts3_desestacionalizada <- ts3 - descomp$seasonal

ts3_desestacionalizada

##           Jan      Feb      Mar      Apr      May      Jun      Jul      Aug
## 2017 158.6753 178.5712 166.8628 170.5712 174.8837 178.9253 176.6545 179.4045
## 2018 179.6753 181.5712 181.8628 185.5712 183.8837 187.9253 188.6545 188.4045
## 2019 198.6753 198.5712 199.8628 197.5712 200.8837 198.9253 197.6545 201.4045
##           Sep      Oct      Nov      Dec
## 2017 179.0087 186.2587 179.8628 176.3212
## 2018 191.0087 186.2587 194.8628 200.3212
## 2019 195.0087 204.2587 200.8628 205.3212

autoplot(ts3_desestacionalizada) +
  ggtitle("Serie de tiempo desestacionalizada") +
  xlab("Año") +
  ylab("Ventas desestacionalizadas (miles de dólares)")

# Crear variable de tiempo
tiempo <- 1:length(ts3_desestacionalizada)

# Modelo de tendencia
modelo_tendencia <- lm(
  as.numeric(ts3_desestacionalizada) ~ tiempo
)

summary(modelo_tendencia)

## 
## Call:
## lm(formula = as.numeric(ts3_desestacionalizada) ~ tiempo)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -11.0403  -2.2175   0.3476   2.4980   7.8314 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 168.69142    1.35774   124.2   <2e-16 ***
## tiempo        1.02419    0.06399    16.0   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 3.989 on 34 degrees of freedom
## Multiple R-squared:  0.8828, Adjusted R-squared:  0.8794 
## F-statistic: 256.2 on 1 and 34 DF,  p-value: < 2.2e-16

# Periodos que corresponden al cuarto año
tiempo_2020 <- 37:48

# Pronóstico de la tendencia
tendencia_2020 <- predict(
  modelo_tendencia,
  newdata = data.frame(tiempo = tiempo_2020)
)

# Índices estacionales para enero-diciembre
estacional_2020 <- descomp$figure

# Pronóstico final
pronostico_descomposicion <- tendencia_2020 + estacional_2020

# Tabla de pronóstico
pronostico_descomposicion <- data.frame(
  Mes = month.abb,
  Pronostico = round(pronostico_descomposicion, 2)
)

pronostico_descomposicion

##    Mes Pronostico
## 1  Jan     289.91
## 2  Feb     264.04
## 3  Mar     273.77
## 4  Apr     217.09
## 5  May     219.80
## 6  Jun     172.78
## 7  Jul     181.08
## 8  Aug     186.35
## 9  Sep     145.77
## 10 Oct     159.55
## 11 Nov     188.97
## 12 Dec     247.53

autoplot(ts3) +
  autolayer(
    ts(
      pronostico_descomposicion$Pronostico,
      start = c(2020, 1),
      frequency = 12
    ),
    series = "Pronóstico"
  ) +
  ggtitle("Pronóstico de ventas - Cuarto año") +
  xlab("Año") +
  ylab("Ventas (miles de dólares)")

# Crear base para regresión
datos_regresion <- data.frame(
  Ventas = as.numeric(ts3),
  Tiempo = 1:length(ts3),
  Mes = factor(cycle(ts3))
)

# Modelo de regresión con variables ficticias
modelo_regresion <- lm(
  Ventas ~ Tiempo + Mes,
  data = datos_regresion
)

summary(modelo_regresion)

## 
## Call:
## lm(formula = Ventas ~ Tiempo + Mes, data = datos_regresion)
## 
## 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 ***
## Tiempo         1.01736    0.07554  13.467 2.14e-12 ***
## Mes2         -20.68403    3.62688  -5.703 8.30e-06 ***
## Mes3         -16.36806    3.62924  -4.510 0.000158 ***
## Mes4         -73.38542    3.63317 -20.199 3.90e-16 ***
## Mes5         -70.73611    3.63866 -19.440 8.97e-16 ***
## Mes6        -117.75347    3.64571 -32.299  < 2e-16 ***
## Mes7        -112.43750    3.65431 -30.768  < 2e-16 ***
## Mes8        -107.12153    3.66445 -29.233  < 2e-16 ***
## Mes9        -151.13889    3.67611 -41.114  < 2e-16 ***
## Mes10       -135.48958    3.68928 -36.725  < 2e-16 ***
## Mes11       -108.50694    3.70395 -29.295  < 2e-16 ***
## Mes12        -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

# Crear datos para los 12 meses del cuarto año
nuevo_2020 <- data.frame(
  Tiempo = 37:48,
  Mes = factor(
    1:12,
    levels = levels(datos_regresion$Mes)
  )
)

# Pronóstico
pronostico_regresion <- predict(
  modelo_regresion,
  newdata = nuevo_2020
)

# Tabla
pronostico_regresion <- data.frame(
  Mes = month.abb,
  Pronostico = round(pronostico_regresion, 2)
)

pronostico_regresion

##    Mes Pronostico
## 1  Jan     286.75
## 2  Feb     267.08
## 3  Mar     272.42
## 4  Apr     216.42
## 5  May     220.08
## 6  Jun     174.08
## 7  Jul     180.42
## 8  Aug     186.75
## 9  Sep     143.75
## 10 Oct     160.42
## 11 Nov     188.42
## 12 Dec     248.08

# Venta real de enero del cuarto año
venta_real_enero <- 295

# Error del pronóstico
error_descomposicion <- venta_real_enero - pronostico_descomposicion$Pronostico[1]
error_regresion <- venta_real_enero - pronostico_regresion$Pronostico[1]

# Error porcentual
error_pct_descomposicion <- abs(error_descomposicion) / venta_real_enero * 100
error_pct_regresion <- abs(error_regresion) / venta_real_enero * 100

errores <- data.frame(
  Metodo = c("Descomposición", "Regresión"),
  Pronostico = c(
    pronostico_descomposicion$Pronostico[1],
    pronostico_regresion$Pronostico[1]
  ),
  Venta_Real = venta_real_enero,
  Error = c(error_descomposicion, error_regresion),
  Error_Porcentual = c(
    error_pct_descomposicion,
    error_pct_regresion
  )
)

errores

##           Metodo Pronostico Venta_Real Error Error_Porcentual
## 1 Descomposición     289.91        295  5.09         1.725424
## 2      Regresión     286.75        295  8.25         2.796610

Ejercicio 4. Carlson Department Store

INSTRUCCIONES: Carlson está involucrada en una disputa con su compañía de seguros sobre el monto de las ventas perdidas durante el tiempo en que la tienda permaneció cerrada. Los dos temas clave que deben ser resueltos son: 1) el importe de las ventas que Carlson habría hecho si no hubiese ocurrido el huracán, y 2) si Carlson tiene derecho a alguna compensación por el exceso de ventas debido al aumento de actividad comercial generado en la zona después del huracán.

# Ventas de Carlson Department Store
Year1_Carlson <- c(NA, NA, NA, NA, NA, NA, NA, NA, 1.71, 1.90, 2.74, 4.20)

Year2_Carlson <- c(1.45, 1.80, 2.03, 1.99, 2.32, 2.20,
                   2.13, 2.43, 1.90, 2.13, 2.56, 4.16)

Year3_Carlson <- c(2.31, 1.89, 2.02, 2.23, 2.39, 2.14,
                   2.27, 2.21, 1.89, 2.29, 2.83, 4.04)

Year4_Carlson <- c(2.31, 1.99, 2.42, 2.45, 2.57, 2.42,
                   2.40, 2.50, 2.09, 2.54, 2.97, 4.35)

Year5_Carlson <- c(2.56, 2.28, 2.69, 2.48, 2.73, 2.37,
                   2.31, 2.23, NA, NA, NA, NA)

ventas_carlson <- c(
  Year1_Carlson,
  Year2_Carlson,
  Year3_Carlson,
  Year4_Carlson,
  Year5_Carlson
)

ts_carlson <- ts(
  ventas_carlson,
  start = c(1, 1),
  frequency = 12
)

# Ventas de las tiendas departamentales del condado
Year1_Condado <- c(NA, NA, NA, NA, NA, NA, NA, NA, 55.80, 56.40, 71.40, 117.60)

Year2_Condado <- c(46.80, 48.00, 60.00, 57.60, 61.80, 58.20,
                   56.40, 63.00, 57.60, 53.40, 71.40, 114.00)

Year3_Condado <- c(46.80, 48.60, 59.40, 58.20, 60.60, 55.20,
                   51.00, 58.80, 49.80, 54.60, 65.40, 102.00)

Year4_Condado <- c(43.80, 45.60, 57.60, 53.40, 56.40, 52.80,
                   54.00, 60.60, 47.40, 54.60, 67.80, 100.20)

Year5_Condado <- c(48.00, 51.60, 57.60, 58.20, 60.00, 57.00,
                   57.60, 61.80, 69.00, 75.00, 85.20, 121.80)

ventas_condado <- c(
  Year1_Condado,
  Year2_Condado,
  Year3_Condado,
  Year4_Condado,
  Year5_Condado
)

ts_condado <- ts(
  ventas_condado,
  start = c(1, 1),
  frequency = 12
)

# Meses de los 48 periodos anteriores al huracán
Mes <- c(
  "Sep", "Oct", "Nov", "Dec",
  "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug",
  "Sep", "Oct", "Nov", "Dec",
  "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug",
  "Sep", "Oct", "Nov", "Dec",
  "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug",
  "Sep", "Oct", "Nov", "Dec",
  "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug"
)

# Ventas de Carlson Department Store
Ventas_Carlson <- c(
  1.71, 1.90, 2.74, 4.20,
  1.45, 1.80, 2.03, 1.99, 2.32, 2.20, 2.13, 2.43,
  1.90, 2.13, 2.56, 4.16,
  2.31, 1.89, 2.02, 2.23, 2.39, 2.14, 2.27, 2.21,
  1.89, 2.29, 2.83, 4.04,
  2.31, 1.99, 2.42, 2.45, 2.57, 2.42, 2.40, 2.50,
  2.09, 2.54, 2.97, 4.35,
  2.56, 2.28, 2.69, 2.48, 2.73, 2.37, 2.31, 2.23
)

# Ventas de las tiendas departamentales del condado
Ventas_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, 56.40, 52.80, 54.00, 60.60, 47.40, 54.60,
  47.40, 54.60, 67.80, 100.20,
  48.00, 51.60, 57.60, 58.20, 60.00, 57.00, 57.60, 61.80
)

# Crear base
datos <- data.frame(
  Tiempo = 1:48,
  Mes = factor(Mes, levels = c(
    "Jan", "Feb", "Mar", "Apr", "May", "Jun",
    "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
  )),
  Ventas_Carlson = Ventas_Carlson,
  Ventas_Condado = Ventas_Condado
)

head(datos)

##   Tiempo Mes Ventas_Carlson Ventas_Condado
## 1      1 Sep           1.71           55.8
## 2      2 Oct           1.90           56.4
## 3      3 Nov           2.74           71.4
## 4      4 Dec           4.20          117.6
## 5      5 Jan           1.45           46.8
## 6      6 Feb           1.80           48.0

modelo_carlson <- lm(
  Ventas_Carlson ~ Tiempo + Mes,
  data = datos
)

summary(modelo_carlson)

## 
## Call:
## lm(formula = Ventas_Carlson ~ Tiempo + Mes, data = datos)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -0.50750 -0.06604  0.00875  0.07458  0.28750 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  1.901944   0.090906  20.922  < 2e-16 ***
## Tiempo       0.011111   0.001753   6.338 2.78e-07 ***
## MesFeb      -0.178611   0.115236  -1.550   0.1301    
## MesMar       0.110278   0.115276   0.957   0.3453    
## MesApr       0.096667   0.115342   0.838   0.4077    
## MesMay       0.300556   0.115436   2.604   0.0134 *  
## MesJun       0.069444   0.115555   0.601   0.5517    
## MesJul       0.053333   0.115701   0.461   0.6477    
## MesAug       0.107222   0.115874   0.925   0.3611    
## MesSep      -0.215556   0.115436  -1.867   0.0702 .  
## MesOct       0.090833   0.115342   0.788   0.4363    
## MesNov       0.639722   0.115276   5.549 3.03e-06 ***
## MesDec       2.041111   0.115236  17.712  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.1629 on 35 degrees of freedom
## Multiple R-squared:  0.9472, Adjusted R-squared:  0.9291 
## F-statistic: 52.35 on 12 and 35 DF,  p-value: < 2.2e-16

# Periodos correspondientes a septiembre-diciembre del Año 5
nuevo <- data.frame(
  Tiempo = 49:52,
  Mes = factor(
    c("Sep", "Oct", "Nov", "Dec"),
    levels = levels(datos$Mes)
  )
)

# Pronóstico de Carlson
pronostico_carlson <- predict(
  modelo_carlson,
  newdata = nuevo
)

pronostico_carlson

##        1        2        3        4 
## 2.230833 2.548333 3.108333 4.520833

modelo_condado <- lm(
  Ventas_Condado ~ Tiempo + Mes,
  data = datos
)

summary(modelo_condado)

## 
## Call:
## lm(formula = Ventas_Condado ~ Tiempo + Mes, data = datos)
## 
## Residuals:
##    Min     1Q Median     3Q    Max 
## -6.480 -2.230  0.160  1.635  7.380 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 48.61167    2.02181  24.044  < 2e-16 ***
## Tiempo      -0.09833    0.03899  -2.522 0.016369 *  
## MesFeb       2.19833    2.56293   0.858 0.396870    
## MesMar      12.19667    2.56382   4.757 3.33e-05 ***
## MesApr      10.64500    2.56530   4.150 0.000202 ***
## MesMay      13.14333    2.56737   5.119 1.12e-05 ***
## MesJun      11.89167    2.57004   4.627 4.92e-05 ***
## MesJul       7.34000    2.57329   2.852 0.007236 ** 
## MesAug      13.88833    2.57713   5.389 4.94e-06 ***
## MesSep       5.90667    2.56737   2.301 0.027486 *  
## MesOct       8.10500    2.56530   3.159 0.003252 ** 
## MesNov      22.45333    2.56382   8.758 2.42e-10 ***
## MesDec      62.00167    2.56293  24.192  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 3.624 on 35 degrees of freedom
## Multiple R-squared:  0.9621, Adjusted R-squared:  0.9491 
## F-statistic: 74.02 on 12 and 35 DF,  p-value: < 2.2e-16

# Pronóstico del condado para septiembre-diciembre
pronostico_condado <- predict(
  modelo_condado,
  newdata = nuevo
)

pronostico_condado

##      1      2      3      4 
##  49.70  51.80  66.05 105.50

tabla_condado <- data.frame(
  Mes = c("Septiembre", "Octubre", "Noviembre", "Diciembre"),
  Pronostico = round(pronostico_condado, 2)
)

tabla_condado

##          Mes Pronostico
## 1 Septiembre      49.70
## 2    Octubre      51.80
## 3  Noviembre      66.05
## 4  Diciembre     105.50

perdida_carlson <- sum(pronostico_carlson)

perdida_carlson

## [1] 12.40833

tabla_perdida <- data.frame(
  Concepto = c(
    "Ventas estimadas sin huracán",
    "Ventas reales durante el cierre",
    "Pérdida estimada"
  ),
  Millones_Dolares = c(
    round(sum(pronostico_carlson), 2),
    0,
    round(perdida_carlson, 2)
  )
)

tabla_perdida

##                          Concepto Millones_Dolares
## 1    Ventas estimadas sin huracán            12.41
## 2 Ventas reales durante el cierre             0.00
## 3                Pérdida estimada            12.41

ventas_reales_condado <- c(69.00, 75.00, 85.20, 121.80)

exceso_condado <- ventas_reales_condado - pronostico_condado

tabla_exceso <- data.frame(
  Mes = c("Septiembre", "Octubre", "Noviembre", "Diciembre"),
  Ventas_Esperadas = round(pronostico_condado, 2),
  Ventas_Reales = ventas_reales_condado,
  Exceso_Ventas = round(exceso_condado, 2)
)

tabla_exceso

##          Mes Ventas_Esperadas Ventas_Reales Exceso_Ventas
## 1 Septiembre            49.70          69.0         19.30
## 2    Octubre            51.80          75.0         23.20
## 3  Noviembre            66.05          85.2         19.15
## 4  Diciembre           105.50         121.8         16.30

total_exceso <- sum(exceso_condado)

total_exceso

## [1] 77.95

resumen_carlson <- data.frame(
  Concepto = c(
    "Ventas estimadas de Carlson sin huracán",
    "Pérdida estimada de Carlson",
    "Ventas esperadas del condado sin huracán",
    "Ventas reales del condado",
    "Exceso de ventas del condado"
  ),
  Millones_Dolares = c(
    round(sum(pronostico_carlson), 2),
    round(perdida_carlson, 2),
    round(sum(pronostico_condado), 2),
    round(sum(ventas_reales_condado), 2),
    round(total_exceso, 2)
  )
)

resumen_carlson

##                                   Concepto Millones_Dolares
## 1  Ventas estimadas de Carlson sin huracán            12.41
## 2              Pérdida estimada de Carlson            12.41
## 3 Ventas esperadas del condado sin huracán           273.05
## 4                Ventas reales del condado           351.00
## 5             Exceso de ventas del condado            77.95