# ETL
library(tidyverse)
library(sparkline)
library(data.table)
library(DT)
library(scales)
# Forecasting
library(forecast)
# Charts
library(highcharter)
library(RColorBrewer)
# Tables
library(reactable)42 MLR Portfolio Forecasts
As usual, we start by uploading the libraries we’re going to use.
43 Set Up Raw Data
Upload Raw Data
We’re going to upload a dataset from the file “actual_sales_data.csv”. This data frame contains historical sales quantities per product and per country.
We will then calculate some statistical forecasts, using the time serie approach MLR (Multi Linear Regression).
This time we are going to calculate the MLR forecasts for a whole portfolio of items.
Several steps are pretty similar to the ones we went through in the previous chapter.
# Upload dataset
# Define the URL of the raw CSV file
url <- "https://raw.githubusercontent.com/nguyennico/sales_forecasting_practice/main/actual_sales_data.csv"
# Read the CSV file from the URL
df1 <- read.csv(url)
# pivot
df1 <- df1 |> gather(key = "period",
value = "actuals",
3:length(df1))
# remove the "X" in front of the period
df1$period <- gsub("X", "",df1$period)
# Format Date
df1$period <- as.Date(df1$period, format = '%m.%d.%Y')
# keep results
initial_data <- df1
head(initial_data) country product_description period actuals
1 Spain ProductA 2016-01-01 1370
2 Mexico ProductB 2016-01-01 0
3 Brazil ProductB 2016-01-01 12
4 Brazil ProductC 2016-01-01 369
5 Germany ProductD 2016-01-01 0
6 France ProductA 2016-01-01 263Transform
# set a working df
df1 <- initial_data
# create a field DFU
df1$DFU <- paste(df1$country, df1$product_description, sep="_")
# keep only needed columns and get results
df1 <- df1 |> select(DFU, period, actuals)
#--------------
# add some Calendar Features
#--------------
# add the calendar_year
df1$calendar_year <- year(df1$period)
# add the calendar_month
df1$calendar_month <- month(df1$period)
# transform the Month number into a month abbreviation
# note that month.abb comes with [ and not (
df1$calendar_month_abb <- month.abb[df1$calendar_month]
# create a Factor for the calendar_month_abb
# setting the beginning to January
df1$calendar_month_abb <- factor(df1$calendar_month_abb,
levels= c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep", "Oct", "Nov", "Dec"))
# Get Results
actuals_data <- df1
head(actuals_data) DFU period actuals calendar_year calendar_month
1 Spain_ProductA 2016-01-01 1370 2016 1
2 Mexico_ProductB 2016-01-01 0 2016 1
3 Brazil_ProductB 2016-01-01 12 2016 1
4 Brazil_ProductC 2016-01-01 369 2016 1
5 Germany_ProductD 2016-01-01 0 2016 1
6 France_ProductA 2016-01-01 263 2016 1
calendar_month_abb
1 Jan
2 Jan
3 Jan
4 Jan
5 Jan
6 Jan44 Portfolio Calculation
44.1 Create Historical Time Serie object
We will consider the Full Historical Window, starting from “2016-01-01” and ending in “2019-06-01”.
44.1.1 Get actuals
# set a working df
df1 <- actuals_data
# select Period (historical window)
df1 <- df1 |> filter(period >= "2016-01-01" & period <= "2019-06-01")
# keep only needed columns
df1 <- df1 |> select(DFU, period, actuals)
# keep a dataframe for charts later on
selected_actuals_data <- df1
head(df1) DFU period actuals
1 Spain_ProductA 2016-01-01 1370
2 Mexico_ProductB 2016-01-01 0
3 Brazil_ProductB 2016-01-01 12
4 Brazil_ProductC 2016-01-01 369
5 Germany_ProductD 2016-01-01 0
6 France_ProductA 2016-01-01 26344.1.2 Convert into a time series object
We need to create a separate time series object for each product. We can use the ts() function to do this.
# define start_date
start_date <- min(selected_actuals_data$period)
# define start_year
start_year <- year(start_date)
# define start_month
start_month <- month(start_date)
start_date[1] "2016-01-01"# generate the ts table
ts_data <- selected_actuals_data |>
group_by(DFU) |>
summarize(ts = list(ts(actuals,
start = c(start_year, start_month),
frequency = 12))
)
glimpse(ts_data)Rows: 8
Columns: 2
$ DFU <chr> "Australia_ProductC", "Brazil_ProductB", "Brazil_ProductC", "Franc…
$ ts <list> <213, 232, 105, 225, 240, 228, 194, 178, 233, 167, 164, 208, 209,…45 Calculate Forecasts (MLR)
45.1 Fit a time series model and forecast
We will need to apply the function tslm() to each item (rows) of the data frame.
To do this we will :
create a function
MLR_forecast_product()to calculate those forecasts over the next 24 months.apply this function to the previous data frame
ts_data.
45.1.1 Create function
#-------------------
# Create Function
#-------------------
# Function to fit model and forecast
MLR_forecast_product <- function(ts) {
fit <- tslm(ts ~ trend + season)
forecast(fit, h = 24) # Forecasting for next 24 months
}45.1.2 Calculate forecasts
We calculate the forecasts for each product.
We also, for our information, can calculate the time needed to perform this calculation, with the value calculation.time .
#-------------------
# Calculate
#-------------------
start_time <- Sys.time()
# Apply the function to each product's time series data
MLR_forecasts <- ts_data |>
rowwise() |>
mutate(forecast = list(MLR_forecast_product(ts))
)
end_time <- Sys.time()
calculation.time <- end_time - start_time
calculation.timeTime difference of 0.112906 secs45.2 Extract forecasts into a data frame
45.2.1 Create function
Let’s create a function forecast_to_df() to convert forecast object to data frame.
Note that here we need to indicate the beginning of the forecasts horizon, so from “2019-07-01”.
# Function
forecast_to_df <- function(forecast_obj, product_name) {
forecast_df <- as.data.frame(forecast_obj)
forecast_df$period <- seq.Date(from = as.Date("2019-07-01"),
by = "month",
length.out = nrow(forecast_df))
forecast_df$DFU <- product_name
forecast_df
}45.2.2 Apply function
We apply this function to the previous data frame :
# set a working df
forecasts <- MLR_forecasts
# Combine all forecasts into a single data frame
df1 <- bind_rows(
lapply(1:nrow(forecasts), function(i) {
forecast_to_df(forecasts$forecast[[i]], forecasts$DFU[i])
})
)
# keep results
MLR_forecast_df <- df1
glimpse(df1)Rows: 192
Columns: 7
$ `Point Forecast` <dbl> 204.33333, 212.33333, 230.00000, 229.66667, 213.33333…
$ `Lo 80` <dbl> 153.53700, 161.53700, 179.20367, 178.87033, 162.53700…
$ `Hi 80` <dbl> 255.1297, 263.1297, 280.7963, 280.4630, 264.1297, 264…
$ `Lo 95` <dbl> 125.11456, 133.11456, 150.78123, 150.44789, 134.11456…
$ `Hi 95` <dbl> 283.5521, 291.5521, 309.2188, 308.8854, 292.5521, 293…
$ period <date> 2019-07-01, 2019-08-01, 2019-09-01, 2019-10-01, 2019…
$ DFU <chr> "Australia_ProductC", "Australia_ProductC", "Australi…46 Prepare for Chart
As we did in the previous chapter, we will combine the calculated forecasts with the actuals in a single data frame.
Prepare Forecasts
# set a working df
df1 <- MLR_forecast_df
# rename
df1 <- df1 |> rename(forecasts = `Point Forecast`)
# add dummy actuals
df1$actuals <- 0
# reorder
df1 <- df1 |> select(DFU, period, actuals, forecasts)
# adjust forecasts : replace all negative values by zero
df1$forecasts <- if_else(df1$forecasts < 0, 0, df1$forecasts)
# keep results
MLR_Forecasts_data <- df1
glimpse(MLR_Forecasts_data)Rows: 192
Columns: 4
$ DFU <chr> "Australia_ProductC", "Australia_ProductC", "Australia_Produ…
$ period <date> 2019-07-01, 2019-08-01, 2019-09-01, 2019-10-01, 2019-11-01,…
$ actuals <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
$ forecasts <dbl> 204.33333, 212.33333, 230.00000, 229.66667, 213.33333, 214.0…Prepare Actuals
# set a working df
df1 <- actuals_data
# add dummy forecasts
df1$forecasts <- 0
# reorder
df1 <- df1 |> select(DFU, period, actuals, forecasts)
# keep results
Actuals_data <- df1
glimpse(df1)Rows: 336
Columns: 4
$ DFU <chr> "Spain_ProductA", "Mexico_ProductB", "Brazil_ProductB", "Bra…
$ period <date> 2016-01-01, 2016-01-01, 2016-01-01, 2016-01-01, 2016-01-01,…
$ actuals <int> 1370, 0, 12, 369, 0, 263, 12, 213, 1528, 0, 47, 368, 0, 298,…
$ forecasts <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …Stack
Now we can combine both actuals and forecasts into a common data frame.
# stack
df1 <- rbind(Actuals_data, MLR_Forecasts_data)
# replace values at zero by NA for a better display
df1$actuals <- if_else(df1$actuals == 0, NA, df1$actuals)
df1$forecasts <- if_else(df1$forecasts == 0, NA, df1$forecasts)
# keep results
calculated_forecasts_data <- df1
glimpse(df1)Rows: 528
Columns: 4
$ DFU <chr> "Spain_ProductA", "Mexico_ProductB", "Brazil_ProductB", "Bra…
$ period <date> 2016-01-01, 2016-01-01, 2016-01-01, 2016-01-01, 2016-01-01,…
$ actuals <dbl> 1370, NA, 12, 369, NA, 263, 12, 213, 1528, NA, 47, 368, NA, …
$ forecasts <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, …47 Chart
Now, let’s display the actuals and the calculated forecasts for one item. Let’s select the DFU “France_ProductA”.
#--------------------
# Select a DFU
#--------------------
# set a working df
df1 <- calculated_forecasts_data
# filter
df1 <- df1 |> filter(DFU == "France_ProductA")
#--------------------
# Chart
#--------------------
highchart() |>
hc_add_series(name = "Actuals",
color = "steelblue",
data = df1$actuals) |>
hc_add_series(name = "Forecasts",
color = "limegreen",
data = df1$forecasts) |>
hc_title(text = "MLR [Multi Linear Regression: Trend + Season] Sales Forecasting") |>
hc_subtitle(text = "in units") |>
hc_xAxis(categories = df1$period) |>
hc_add_theme(hc_theme_google())