DS4B - Forecast

Entendimiento de la Organización y Caso de Negocio

Maderas ABC es una Compañía dedicada a la fabricación de tableros de madera aglomerada MDP- “Medium Density Particle Board”, o tableros de partículas de madera de densidad media, en diferentes espesores, formatos y amplia línea de diseños; la cual busca mejorar sus procesos de producción y abastecimiento. En esta oportunidad, a través de información histórica de unidades vendidas, se pretende alcanzar tres objetivos importantes:

1. Automatizar el proceso de extracción, transformación, análisis y visualización de datos.
2. Desarrollar modelos de pronóstico de la demanda para optimizar procesos de abastacimiento de insumos y stock de inventarios.
3. Tomar decisiones con el modelo que tenga un mejor desempeño.

Impacto en el Negocio

Inicialmente, la proyección de la demanda era responsabilidad del área comercial de la Compañía pero la precisión de las estimaciones estaba en un rango entre el 12% al 15%, generando desaciertos en el proceso de abastecimiento. El proceso de estimar la demanda pasó al área de Supply Chain y ha conseguido aumentar la precisión a un 60%. Buscamos, entonces, incrementar la precisión del modelo actual para optimizar los inventarios, aprovisionar y comprar materia prima para el desarrollo de los productos.

Librerías

library(DataExplorer)
library(tidymodels)
library(modeltime)
library(tidyverse)
library(plyr)
library(lubridate)
library(timetk)
library(earth)
library(zoo)
library(tseries)
library(viridis)
library(networkD3)
library(summarytools)

Obtención de los Datos

setwd("C:/Users/Jorge Avellaneda/Downloads")
df <- read.csv("maderasabc.csv", header = T, sep = ";")

Transformación de los Datos

df <- df %>% 
  mutate(Cmpy = as.factor(Cmpy),
         Año = as.factor(Año),
         Mes = as.factor(Mes),
         Bodega = as.factor(Bodega),
         TipoDoc = as.factor(TipoDoc),
         Documento = as.factor(Documento),
         Moneda = as.factor(Moneda),
         TRM = as.numeric(TRM),
         IdCliente = as.factor(IdCliente),
         Id = as.factor(Id),
         Item = as.factor(Item),
         FactorArea = as.factor(FactorArea),
         CategoriaID = as.factor(CategoriaID),
         Categoría = as.factor(Categoría),
         LineaID = as.factor(LineaID),
         Familia = as.factor(Familia),
         ConjuntoID = as.factor(ConjuntoID),
         Conjunto = as.factor(Conjunto),
         Cantidad = as.numeric(Cantidad),
         Nal.Exp = as.factor(Nal.Exp),
         Fecha = as.Date(Fecha, format="%d/%m/%Y"),
         Factor.Volumen = as.numeric(Factor.Volumen),
         Volumen = as.numeric(Volumen),
         Pedido = as.factor(Pedido),
         Fecha.pedido = as.Date(Fecha.pedido, format = "%d/%m/%Y"),
         DisId   = as.factor( DisId),
         Diseno = as.factor(Diseno),
         GrabId = as.factor(GrabId),
         Grabado = as.factor(Grabado)) %>% 
  filter(Cantidad >= 0) %>% 
  drop_na(Cantidad)
df$weekday = as.POSIXlt(df$Fecha)$wday
df$weekdayf <- factor(df$weekday,
                      levels = rev(1:7),
                      labels = rev(c("Lun",
                                     "Mar",
                                     "Mie",
                                     "Jue",
                                     "Vie",
                                     "Sab",
                                     "Dom")),
                      ordered=TRUE)
df$monthf <- factor(month(df$Fecha),
                    levels=as.character(1:12),
                    labels=c("Ene",
                             "Feb",
                             "Mar",
                             "Abr",
                             "May",
                             "Jun",
                             "Jul",
                             "Ago",
                             "Sep",
                             "Oct",
                             "Nov",
                             "Dic"),
                    ordered=TRUE)

df$yearmonth <- factor(as.yearmon(df$Fecha))
df$year <- format(df$Fecha, format = "%Y")
df$week <- as.numeric(format(df$Fecha,"%W"))
df <- ddply(df,.(yearmonth),
          transform,
          monthweek = 1  +week-min(week))

Descripción de las variables

En la siguiente sección se presenta una breve descripción de cada variables del dataset, esto nos permitirá conocer el tipo de variable y un resumen.

print(dfSummary(df, valid.col = FALSE, graph.magnif = 0.75), 
      max.tbl.height = 300, method = "render")

Data Frame Summary

df

Dimensions: 15329 x 40
Duplicates: 2

No	Variable	Stats / Values	Freqs (% of Valid)	Graph	Missing
1	Cmpy [factor]	1. MA	15329 ( 100.0% )		0 (0%)
2	Año [factor]	1. 2019 2. 2020	9562 ( 62.4% ) 5767 ( 37.6% )		0 (0%)
3	Mes [factor]	1. 1 2. 2 3. 3 4. 4 5. 5 6. 6 7. 7 8. 8 9. 9 10. 10 [ 2 others ]	1241 ( 8.1% ) 1686 ( 11.0% ) 1449 ( 9.5% ) 1000 ( 6.5% ) 1467 ( 9.6% ) 1855 ( 12.1% ) 2024 ( 13.2% ) 1342 ( 8.8% ) 885 ( 5.8% ) 875 ( 5.7% ) 1505 ( 9.8% )		0 (0%)
4	Bodega [factor]	1. -  ·· 2. PCU 3. PRP 4. PRT 5. PTM 6. PTP 7. PTR 8. PTS 9. SAL	49 ( 0.3% ) 8 ( 0.0% ) 154 ( 1.0% ) 1 ( 0.0% ) 20 ( 0.1% ) 13865 ( 90.5% ) 141 ( 0.9% ) 2 ( 0.0% ) 1089 ( 7.1% )		0 (0%)
5	TipoDoc [factor]	1. IN 2. NC 3. ND	15274 ( 99.6% ) 0 ( 0.0% ) 55 ( 0.4% )		0 (0%)
6	Documento [factor]	1. 875 2. 876 3. 877 4. 879 5. 880 6. 889 7. 890 8. 893 9. 7376 10. 7377 [ 10899 others ]	2 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 0 ( 0.0% ) 0 ( 0.0% ) 15320 ( 99.9% )		0 (0%)
7	Moneda [factor]	1. DA  · 2. PE  ·	84 ( 0.5% ) 15245 ( 99.5% )		0 (0%)
8	TRM [numeric]	Mean (sd) : 3426 (238) min < med < max: 3072 < 3401 < 4153.9 IQR (CV) : 388 (0.1)	365 distinct values		0 (0%)
9	IdCliente [factor]	1. 102695961 2. 1074184799 3. 1098706205 4. 1123086861 5. 122372729 6. 129866907 7. 163689288 8. 167528801 9. 171328258 10. 171808965 [ 196 others ]	10 ( 0.1% ) 17 ( 0.1% ) 360 ( 2.3% ) 36 ( 0.2% ) 3 ( 0.0% ) 113 ( 0.7% ) 50 ( 0.3% ) 14 ( 0.1% ) 12 ( 0.1% ) 7 ( 0.0% ) 14707 ( 95.9% )		0 (0%)
10	Id [factor]	1. 31040006 2. 32010001 3. 32010002 4. 32010003 5. 32010004 6. 32010005 7. 32010006 8. 32010007 9. 32010008 10. 32010010 [ 507 others ]	1 ( 0.0% ) 15 ( 0.1% ) 45 ( 0.3% ) 5 ( 0.0% ) 39 ( 0.3% ) 19 ( 0.1% ) 63 ( 0.4% ) 50 ( 0.3% ) 36 ( 0.2% ) 6 ( 0.0% ) 15050 ( 98.2% )		0 (0%)
11	Item [factor]	1. FMTCR0C FINALIZ RH 18X183 2. FMTMA2C FORMALE RH 09X183 3. FMTMA2C FORMALE RH 15X183 4. FMTMA2C FORMALE RH 18X183 5. INSHDPFOLIO GU挼㸱ITARA ST 0 6. INSHDPFOLIO GUATAPUR挼㹤 ST 7. INSHDPFOLIO YARI ST 03X18 8. MDLCR0C MODULO ST 09X1000 9. MDLCR0C MODULO ST 09X1130 10. MDLCR0C MODULO ST 09X1150 [ 507 others ]	1 ( 0.0% ) 2 ( 0.0% ) 25 ( 0.2% ) 296 ( 1.9% ) 1 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 3 ( 0.0% ) 1 ( 0.0% ) 4 ( 0.0% ) 14994 ( 97.8% )		0 (0%)
12	FactorArea [factor]	1. 1	10524 ( 100.0% )		4805 (31.35%)
13	CategoriaID [factor]	1. -  ····· 2. 1 3. 16 4. 19 5. 2 6. 25 7. 26 8. 3 9. 34 10. 35 [ 9 others ]	2 ( 0.0% ) 408 ( 2.7% ) 88 ( 0.6% ) 3 ( 0.0% ) 527 ( 3.4% ) 1 ( 0.0% ) 16 ( 0.1% ) 13879 ( 90.5% ) 102 ( 0.7% ) 37 ( 0.2% ) 266 ( 1.7% )		0 (0%)
14	Categoría [factor]	1. -  ························ 2. Tama? 0.80 x 0.80  ········ 3. Tama? 0.975 x 0.975  ······ 4. Tama? 0.979 x 0.979  ······ 5. Tama? 1.150 x 1.150  ······ 6. Tama? 1.22 x 2.44  ········ 7. Tama? 1.53 x 2.44  ········ 8. Tama? 1.83 x 2.44  ········ 9. Tama? 2.14 x 2.44  ········ 10. TAMA?O 0.575 X 0.585  ····· [ 18 others ]	2 ( 0.0% ) 3 ( 0.0% ) 3 ( 0.0% ) 0 ( 0.0% ) 1 ( 0.0% ) 16 ( 0.1% ) 6 ( 0.0% ) 659 ( 4.3% ) 10 ( 0.1% ) 0 ( 0.0% ) 14629 ( 95.4% )		0 (0%)
15	LineaID [factor]	1. -  · 2. 64 3. 65 4. 66 5. 70	2 ( 0.0% ) 2748 ( 17.9% ) 12243 ( 79.9% ) 13 ( 0.1% ) 323 ( 2.1% )		0 (0%)
16	FamiliaID [character]	1. -  ·· 2. RH  · 3. STD	2 ( 0.0% ) 7137 ( 46.6% ) 8190 ( 53.4% )		0 (0%)
17	Familia [factor]	1. -  ··················· 2. ESTANDAR  ············ 3. RH  ··················	2 ( 0.0% ) 8190 ( 53.4% ) 7137 ( 46.6% )		0 (0%)
18	ConjuntoID [factor]	1. -  ·· 2. 12 3. 15 4. 18 5. 25 6. 30 7. 36 8. 4 9. 6 10. 9	2 ( 0.0% ) 258 ( 1.7% ) 8990 ( 58.7% ) 2186 ( 14.3% ) 883 ( 5.8% ) 437 ( 2.8% ) 369 ( 2.4% ) 3 ( 0.0% ) 1793 ( 11.7% ) 408 ( 2.7% )		0 (0%)
19	Conjunto [factor]	1. -  ························ 2. Espesor 12  ··············· 3. Espesor 15  ··············· 4. Espesor 18  ··············· 5. Espesor 25  ··············· 6. Espesor 30  ··············· 7. Espesor 36  ··············· 8. Espesor 4  ················ 9. Espesor 6  ················ 10. Espesor 9  ················	2 ( 0.0% ) 258 ( 1.7% ) 8990 ( 58.7% ) 2186 ( 14.3% ) 883 ( 5.8% ) 437 ( 2.8% ) 369 ( 2.4% ) 3 ( 0.0% ) 1793 ( 11.7% ) 408 ( 2.7% )		0 (0%)
20	División [integer]	1 distinct value	350 : 15329 ( 100.0% )		0 (0%)
21	Cantidad [numeric]	Mean (sd) : 82.4 (229.9) min < med < max: 1 < 40 < 10500 IQR (CV) : 50 (2.8)	259 distinct values		0 (0%)
22	Nal.Exp [factor]	1. E 2. N	84 ( 0.5% ) 15245 ( 99.5% )		0 (0%)
23	Fecha [Date]	min : 2019-01-09 med : 2019-10-22 max : 2020-08-18 range : 1y 7m 9d	419 distinct values		0 (0%)
24	O.P. [integer]	1 distinct value	0 : 11942 ( 100.0% )		3387 (22.1%)
25	Fecha.OP [logical]	All NA's			15329 (100%)
26	Factor.Volumen [numeric]	Mean (sd) : 0.1 (0) min < med < max: 0 < 0.1 < 0.2 IQR (CV) : 0 (0.4)	61 distinct values		0 (0%)
27	Volumen [numeric]	Mean (sd) : 4.5 (8.7) min < med < max: 0 < 2.7 < 703.2 IQR (CV) : 3.5 (1.9)	582 distinct values		0 (0%)
28	Pedido [factor]	1. 0 2. 5260 3. 5754 4. 5861 5. 6233 6. 6237 7. 6242 8. 6283 9. 6293 10. 6335 [ 4826 others ]	151 ( 1.0% ) 0 ( 0.0% ) 0 ( 0.0% ) 1 ( 0.0% ) 0 ( 0.0% ) 0 ( 0.0% ) 2 ( 0.0% ) 0 ( 0.0% ) 1 ( 0.0% ) 1 ( 0.0% ) 15173 ( 99.0% )		0 (0%)
29	Fecha.pedido [Date]	min : 2018-08-03 med : 2019-10-09 max : 2020-08-13 range : 2y 0m 10d	461 distinct values		151 (0.99%)
30	DisId [factor]	1. 1 2. 2 3. 10 4. 13 5. 14 6. 15 7. 18 8. 19 9. 21 10. 22 [ 13 others ]	214 ( 1.9% ) 1665 ( 14.8% ) 323 ( 2.9% ) 127 ( 1.1% ) 36 ( 0.3% ) 71 ( 0.6% ) 96 ( 0.9% ) 49 ( 0.4% ) 267 ( 2.4% ) 413 ( 3.7% ) 8017 ( 71.1% )		4051 (26.43%)
31	Diseno [factor]	1. (Empty string) 2. -  ························ 3. Amora Ash  ················ 4. Artico  ··················· 5. Cocuy  ···················· 6. Formaleta  ················ 7. Humo  ····················· 8. Khaki  ···················· 9. London  ··················· 10. Nacar  ···················· [ 9 others ]	4598 ( 30.0% ) 4051 ( 26.4% ) 214 ( 1.4% ) 1665 ( 10.9% ) 126 ( 0.8% ) 323 ( 2.1% ) 127 ( 0.8% ) 36 ( 0.2% ) 71 ( 0.5% ) 96 ( 0.6% ) 4022 ( 26.2% )		0 (0%)
32	GrabId [factor]	1. 0 2. 2 3. 3 4. 4 5. 5 6. 6 7. 7 8. 8	2758 ( 18.0% ) 3 ( 0.0% ) 2694 ( 17.6% ) 30 ( 0.2% ) 423 ( 2.8% ) 9299 ( 60.7% ) 12 ( 0.1% ) 108 ( 0.7% )		2 (0.01%)
33	Grabado [factor]	1. -  ························ 2. CORIUM  ··················· 3. CRUDO  ···················· 4. LE?O  ····················· 5. LEÑO  ····················· 6. MATE  ····················· 7. NATURE  ··················· 8. PORO  ····················· 9. QUADRATTO  ················ 10. TEXTURA  ··················	2 ( 0.0% ) 12 ( 0.1% ) 2758 ( 18.0% ) 3 ( 0.0% ) 27 ( 0.2% ) 2694 ( 17.6% ) 423 ( 2.8% ) 9299 ( 60.7% ) 108 ( 0.7% ) 3 ( 0.0% )		0 (0%)
34	weekday [integer]	Mean (sd) : 3.3 (1.5) min < med < max: 0 < 3 < 6 IQR (CV) : 2 (0.5)	0 : 16 ( 0.1% ) 1 : 2138 ( 14.0% ) 2 : 3174 ( 20.7% ) 3 : 3255 ( 21.2% ) 4 : 2955 ( 19.3% ) 5 : 2914 ( 19.0% ) 6 : 877 ( 5.7% )		0 (0%)
35	weekdayf [ordered, factor]	1. Dom 2. Sab 3. Vie 4. Jue 5. Mie 6. Mar 7. Lun	0 ( 0.0% ) 877 ( 5.7% ) 2914 ( 19.0% ) 2955 ( 19.3% ) 3255 ( 21.3% ) 3174 ( 20.7% ) 2138 ( 14.0% )		16 (0.1%)
36	monthf [ordered, factor]	1. Ene 2. Feb 3. Mar 4. Abr 5. May 6. Jun 7. Jul 8. Ago 9. Sep 10. Oct [ 2 others ]	1241 ( 8.1% ) 1686 ( 11.0% ) 1449 ( 9.5% ) 1000 ( 6.5% ) 1467 ( 9.6% ) 1855 ( 12.1% ) 2024 ( 13.2% ) 1342 ( 8.8% ) 885 ( 5.8% ) 875 ( 5.7% ) 1505 ( 9.8% )		0 (0%)
37	yearmonth [factor]	1. Jan 2019 2. Feb 2019 3. Mar 2019 4. Apr 2019 5. May 2019 6. Jun 2019 7. Jul 2019 8. Aug 2019 9. Sep 2019 10. Oct 2019 [ 10 others ]	702 ( 4.6% ) 779 ( 5.1% ) 751 ( 4.9% ) 879 ( 5.7% ) 722 ( 4.7% ) 638 ( 4.2% ) 864 ( 5.6% ) 962 ( 6.3% ) 885 ( 5.8% ) 875 ( 5.7% ) 7272 ( 47.4% )		0 (0%)
38	year [character]	1. 2019 2. 2020	9562 ( 62.4% ) 5767 ( 37.6% )		0 (0%)
39	week [numeric]	Mean (sd) : 23.4 (13.6) min < med < max: 0 < 24 < 52 IQR (CV) : 21 (0.6)	53 distinct values		0 (0%)
40	monthweek [numeric]	Mean (sd) : 3.2 (1.3) min < med < max: 1 < 3 < 5 IQR (CV) : 2 (0.4)	1 : 1739 ( 11.3% ) 2 : 3391 ( 22.1% ) 3 : 3528 ( 23.0% ) 4 : 3275 ( 21.4% ) 5 : 3396 ( 22.1% )		0 (0%)

Generated by summarytools 0.9.6 (R version 4.0.0)
2021-01-15

Visualización de Datos

La variable objetivo del problema de negocio es la cantidad de unidades vendidas. Agrupamos los datos por día de venta y resumimos sumando las unidades vendidas por día. Además, se realiza la identificación de datos que no son frecuentes o anñomalos. Finalmente, se identifica la estacionalidad a través de gráficas de caja o boxplot agrupando por días, semanas, meses y trimestres.

plot_units_groupday <- df %>% 
  dplyr::group_by(Fecha) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  plot_time_series(Fecha, Q)
plot_units_groupday 

anomaly_units_groupday <- df %>% 
  dplyr::group_by(Fecha) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  plot_anomaly_diagnostics(Fecha, Q, 
                             .facet_ncol = 3, .interactive = T)
anomaly_units_groupday 

seasonal_units_groupday <- df %>% 
  dplyr::group_by(Fecha) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  plot_seasonal_diagnostics(Fecha, Q, .interactive = T)
seasonal_units_groupday 

¿Cómo es el comportamiento de las unidades vendidas?

Top 5 de los Items más vendidos

table_items <- df %>% 
  dplyr::group_by(Item) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  dplyr::arrange(desc(Q)) %>% 
  dplyr::slice(1:5)
table_items

## # A tibble: 5 x 2
##   Item                                      Q
##   <fct>                                 <dbl>
## 1 "MDLCR0C MODULO ST 25X0800X0800X6\"" 138102
## 2 "MDLCR0C MODULO ST 18X0575X0585X6\"" 116494
## 3 "PCRMA2C ARTICO RH 15X1830x2440"      89976
## 4 "PCRPR2C WENGUE RH 15X1830x2440"      60346
## 5 "FMTMA2C FORMALE RH 18X1830X2440"     52626

p0 <- df %>% 
  dplyr::filter(Item %in% c('MDLCR0C MODULO ST 25X0800X0800X6"',
                            'MDLCR0C MODULO ST 18X0575X0585X6"',
                            'PCRMA2C ARTICO RH 15X1830x2440',
                            'PCRPR2C WENGUE RH 15X1830x2440',
                            'FMTMA2C FORMALE RH 18X1830X2440')) %>% 
  dplyr::group_by(yearmonth, Item) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  ggplot(aes(x = yearmonth, y = Q)) +
  geom_col(fill = "white", colour = "salmon") +
  theme(axis.ticks = element_line(size = 2),
        axis.text.x = element_text(angle = 90,
        vjust = 0.5, 
        hjust = 1,
        size = 7),
        strip.text.x = element_text(size = 5)) +
  facet_wrap(~ Item)
p0

Top 5 de las categorías más vendidas

table_categoria <- df %>% 
  dplyr::group_by(Categoría) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  dplyr::arrange(desc(Q)) %>% 
  dplyr::slice(1:5)
table_categoria

## # A tibble: 5 x 2
##   Categoría                              Q
##   <fct>                              <dbl>
## 1 "Tamaño 1.83 x 2.44            " 814359.
## 2 "Tamaño 0.80 x 0.80            " 135902 
## 3 "TAMAÑO 0.575 X 0.585          " 126994 
## 4 "Tamaño 1.53 x 2.44            "  48118 
## 5 "Tamaño 1.22 x 2.44            "  46521

Comportamiento Unidades Vendidas por Categoría

p1 <- df %>% 
  dplyr::group_by(yearmonth, Categoría) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  ggplot(aes(x = yearmonth, y = Q)) +
  geom_col(fill = "white", colour = "salmon") +
  theme(axis.ticks = element_line(size = 2),
        axis.text.x = element_text(angle = 90,
        vjust = 0.5, 
        hjust=1,
        size = 5),
        strip.text.x = element_text(size = 5)) +
  facet_wrap(~ Categoría)
p1

Comportamiento Unidades Vendidas por Conjunto

p0 <- df %>% 
  dplyr::group_by(yearmonth, Conjunto) %>% 
  dplyr::summarise(Q = sum(Cantidad)) %>% 
  ggplot(aes(x = yearmonth, y = Q)) +
  geom_col(fill = "white", colour = "salmon") +
  theme(axis.ticks = element_line(size = 2),
        axis.text.x = element_text(angle = 90,
        vjust = 0.5, 
        hjust = 1,
        size = 7)) +
  facet_wrap(~ Conjunto)
p0

El siguiente mapa de calor nos permite identificar los días del mes en los cuales se realizaron transacciones de ventas, e identificar los días en los cuales hubo transacciones con cantidades importantes, por ejemplo el jueves de la 5° semana de agosto del 2019, hubo una transacción por encima de las 10.000 unidades. Además, también podemos visualizar el impacto que tuvo el estado de emergencia decretado por el Gobierno Nacional, en los meses de marzo y abril del 2020, pues hubo 15 días sin ventas. A partir del mes de mayo del 2020 la cantidad de unidades vendidas comenzó a estabilizarse otra vez, pero en un rango por debajo de 2500 unidades.

p <- df %>% 
  tidyr::drop_na(weekdayf) %>% 
  ggplot(aes(monthweek, weekdayf, fill = Cantidad)) + 
  geom_tile(colour = "white") + 
  facet_grid(year(Fecha)~monthf) + 
  scale_fill_viridis_c() +  
  xlab("Semana del Mes") + 
  ylab("") + 
  ggtitle("Mapa de Calor: Unidades Vendidas por Transacción") + 
  labs(fill = "Cantidades")
p

Proyección de la Demanda

En los datos históricos de ventas hay más de 500 tipos de productos, lo que cual hace que este proyecto sea extenso si se realiza producto por producto. Además, algunos items tienen ventas esporádicas o con poca frecuencia. Según lo anterior, y para hacer el primer ejercicio, se utilizó todo el dataset de unidades vendidas.

units_transactions_tbl <- df %>%
  dplyr::select(Fecha, Cantidad) %>% 
  dplyr::group_by(Fecha) %>% 
  dplyr::summarise(Cantidad = sum(Cantidad))
units_transactions_tbl

## # A tibble: 419 x 2
##    Fecha      Cantidad
##    <date>        <dbl>
##  1 2019-01-09      346
##  2 2019-01-10     5390
##  3 2019-01-11     3305
##  4 2019-01-14     5946
##  5 2019-01-15     2448
##  6 2019-01-16     6011
##  7 2019-01-17     1389
##  8 2019-01-18      703
##  9 2019-01-19     1900
## 10 2019-01-21     3409
## # ... with 409 more rows

Datos de Entrenamiento y Prueba

splits <- units_transactions_tbl %>%
  time_series_split(assess = "5 months", 
                    cumulative = TRUE)
splits %>%
  tk_time_series_cv_plan() %>%
  plot_time_series_cv_plan(Fecha, 
                           Cantidad, 
                           .interactive = T)

ARIMA

model_fit_arima_no_boost <- arima_reg() %>%
    set_engine(engine = "auto_arima") %>%
    fit(Cantidad ~ Fecha, data = training(splits))

Boosted ARIMA

model_fit_arima_boosted <- arima_boost(min_n = 2,
                                       learn_rate = 0.015) %>%
    set_engine(engine = "auto_arima_xgboost") %>%
    fit(Cantidad ~ Fecha + as.numeric(Fecha) + factor(month(Fecha, label = T), ordered = F),
        data = training(splits))

ETS

model_fit_ets <- exp_smoothing() %>%
    set_engine(engine = "ets") %>%
    fit(Cantidad ~ Fecha, data = training(splits))

Regresión Lineal (Parnsip)

model_fit_lm <- linear_reg() %>%
    set_engine("lm") %>%
    fit(Cantidad ~ as.numeric(Fecha) + 
          factor(month(Fecha, 
                       label = T), 
                 ordered = F),
        data = training(splits))

MARS (Multivariate Adaptive Regression Spline)

model_spec_mars <- mars(mode = "regression") %>%
    set_engine("earth") 

recipe_spec <- recipe(Cantidad ~ Fecha, data = training(splits)) %>%
    step_date(Fecha, features = "month", ordinal = F) %>%
    step_mutate(date_num = as.numeric(Fecha)) %>%
    step_normalize(date_num) %>%
    step_rm(Fecha)
  
wflw_fit_mars <- workflow() %>%
    add_recipe(recipe_spec) %>%
    add_model(model_spec_mars) %>%
    fit(training(splits))

Tabla de Modelos

models_tbl <- modeltime_table(
    model_fit_arima_no_boost,
    model_fit_arima_boosted,
    model_fit_ets,
    model_fit_lm,
    wflw_fit_mars)
models_tbl

## # Modeltime Table
## # A tibble: 5 x 3
##   .model_id .model     .model_desc                                      
##       <int> <list>     <chr>                                            
## 1         1 <fit[+]>   ARIMA(1,0,0) WITH NON-ZERO MEAN                  
## 2         2 <fit[+]>   ARIMA(1,0,0) WITH NON-ZERO MEAN W/ XGBOOST ERRORS
## 3         3 <fit[+]>   ETS(M,N,A)                                       
## 4         4 <fit[+]>   LM                                               
## 5         5 <workflow> EARTH

Calibración de los Modelos

calibration_tbl <- models_tbl %>%
    modeltime_calibrate(new_data = testing(splits))
calibration_tbl

## # Modeltime Table
## # A tibble: 5 x 5
##   .model_id .model    .model_desc                        .type .calibration_data
##       <int> <list>    <chr>                              <chr> <list>           
## 1         1 <fit[+]>  ARIMA(1,0,0) WITH NON-ZERO MEAN    Test  <tibble [116 x 4~
## 2         2 <fit[+]>  ARIMA(1,0,0) WITH NON-ZERO MEAN W~ Test  <tibble [116 x 4~
## 3         3 <fit[+]>  ETS(M,N,A)                         Test  <tibble [116 x 4~
## 4         4 <fit[+]>  LM                                 Test  <tibble [116 x 4~
## 5         5 <workflo~ EARTH                              Test  <tibble [116 x 4~

Visualización de la Prueba de la Proyección

calibration_tbl %>%
    modeltime_forecast(new_data = testing(splits),
        actual_data = units_transactions_tbl) %>%
    plot_modeltime_forecast(.legend_max_width = 25)

Métricas de Desempeño de los Modelos

calibration_tbl %>%
    modeltime_accuracy() %>%
    table_modeltime_accuracy(.interactive = T)

Forecast

refit_tbl <- calibration_tbl %>%
    modeltime_refit(data = units_transactions_tbl)

refit_tbl %>%
    modeltime_forecast(h = '1 months', actual_data = units_transactions_tbl) %>%
    plot_modeltime_forecast(.legend_max_width = 25)