Peter Laurinec

Overview of clustering methods in R

Thu, 11 Jan 2024 00:00:00 +0000

Clustering is a very popular technique in data science because of its unsupervised characteristic - we don’t need true labels of groups in data. In this blog post, I will give you a “quick” survey of various clustering methods applied to synthetic but also real datasets.

What is clustering?

Cluster analysis or clustering is the task of grouping a set of objects in such a way that objects in the same group (called a cluster) are more similar (in some sense or another) to each other than to those in other groups (clusters).

It is a technique of unsupervised learning, so clustering is used when no a priori information about data is available. This makes clustering a very strong technique for gaining insights into data and making more accurate decisions.

What is it good for?

Clustering is used for:

To gain insight into data, generate hypotheses, detect anomalies, and identify salient features,
To identify the degree of similarity among objects (i.e. organisms),
As a method for organizing the data and summarising it through cluster prototypes (compression).

Classification to groups

The first use case is to group data, e.g. classify them into groups. For explanation purposes, I will generate synthetic data from three normal distributions plus three outliers (anomalies). Let’s load needed packages, generate randomly some data, and show the first use case in the visualization:

library(data.table) # data handling
library(ggplot2) # visualisations
library(gridExtra) # visualisations
library(grid) # visualisations
library(cluster) # PAM - K-medoids
 
set.seed(54321)
 
data_example <- data.table(x = c(rnorm(10, 3.5, 0.1), rnorm(10, 2, 0.1),
                                 rnorm(10, 4.5, 0.1), c(5, 1.9, 3.95)),
                           y = c(rnorm(10, 3.5, 0.1), rnorm(10, 2, 0.1),
                                 rnorm(10, 4.5, 0.1), c(1.65, 2.9, 4.2)))
 
gg1 <- ggplot(data_example, aes(x, y)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw()
 
kmed_res <- pam(data_example, 3)$clustering
 
data_example[, class := as.factor(kmed_res)]
 
gg2 <- ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw()
 
define_region <- function(row, col){
  viewport(layout.pos.row = row, layout.pos.col = col)
}
 
grid.newpage()
# Create layout : nrow = 2, ncol = 2
pushViewport(viewport(layout = grid.layout(1, 2)))
# Arrange the plots
print(gg1, vp = define_region(1, 1))
print(gg2, vp = define_region(1, 2))

We can see three nicely divided groups of data.

Anomaly detection

Clustering can be also used as an anomaly detection technique, some methods of clustering can detect automatically outliers (anomalies). Let’s show visually what it looks like.

anom <- c(rep(1, 30), rep(0, 3))
data_example[, class := as.factor(anom)]
levels(data_example$class) <- c("Anomaly", "Normal")
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw()

Data compression

In an era of a large amount of data (also many times used buzzword - big data), we have problems processing them in real time. Here clustering can help to reduce dimensionality by its compression feature. Created clusters, that incorporate multiple points (data), can be replaced by their representatives (prototypes) - so one point. In this way, points were replaced by its cluster representative (“+”):

data_example[, class := as.factor(kmed_res)]
 
centroids <- data_example[, .(x = mean(x), y = mean(y)), by = class]
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  geom_point(data = centroids, aes(x, y), color = "black", shape = "+", size = 18) +
  theme_bw()

Types of clustering methods

Since cluster analysis has been here for more than 50 years, there are a large amount of available methods. The basic classification of clustering methods is based on the objective to which they aim: hierarchical, non-hierarchical.

The hierarchical clustering is a multi-level partition of a dataset that is a branch of classification (clustering). Hierarchical clustering has two types of access to data. The first one, divisive clustering, starts with one big cluster that is then divided into smaller clusters. The second one, agglomerative clustering, starts with individual objects that are single-element clusters, and then they are gradually merged. The whole process of hierarchical clustering can be expressed (visualized) as a dendrogram.

The non-hierarchical clustering is dividing a dataset into a system of disjunctive subsets (clusters) so that an intersection of clusters would be an empty set.

Clustering methods can be also divided in more detail based on the processes in the method (algorithm) itself:

Non-hierarchical:

Centroid-based
Model-based
Density-based
Grid-based

Hierarchical:

Agglomerative
Divisive

But which to choose in your use case? Let’s dive deeper into the most known methods and discuss their advantages and disadvantages.

Centroid-based

The most basic (maybe just for me) type of clustering method is centroid-based. This type of clustering creates prototypes of clusters - centroids or medoids.

The best well-known methods are:

K-means
K-medians
K-medoids
K-modes

K-means

Steps:

Create random K clusters (and compute centroids).
Assign points to the nearest centroids.
Update centroids.
Go to step 2 while the centroids are changing.

Pros and cons:

[+] Fast to compute. Easy to understand.
[-] Various initial clusters can lead to different final clustering.
[-] Scale-dependent.
[-] Creates only convex (spherical) shapes of clusters.
[-] Sensitive to outliers.

K-means - example

It is very easy to try K-means in R (by the kmeans function), only needed parameter is a number of clusters.

km_res <- kmeans(data_example, 3)$cluster
 
data_example[, class := as.factor(km_res)]
 
centroids <- data_example[, .(x = mean(x), y = mean(y)), by = class]
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  geom_point(data = centroids, aes(x, y), color = "black", shape = "+", size = 18) +
  theme_bw()

We can see example, when K-means fails most often, so when there are outliers in the dataset.

K-medoids

The problem with outliers solves K-medoids because prototypes are medoids - members of the dataset. So, not artificially created centroids, which helps to tackle outliers.

Pros and cons:

[+] Easy to understand.
[+] Less sensitive to outliers.
[+] Possibility to use any distance measure.
[-] Various initial clusters can lead to different final clustering.
[-] Scale-dependent.
[-] Slower than K-means.

K-medoids - example

K-medoids problem can be solved by the Partition Around Medoids (PAM) algorithm (function pam in cluster package).

kmed_res <- pam(data_example[, .(x, y)], 3)
data_example[, class := as.factor(kmed_res$clustering)]
 
medoids <- data.table(kmed_res$medoids, class = as.factor(1:3))
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  geom_point(data = medoids, aes(x, y, shape = class),
             color = "black", size = 11, alpha = 0.7) +
  theme_bw() +
  guides(shape = "none")

We can see that medoids stayed nicely in the three main groups of data.

The determination of the number of clusters

The disadvantage of centroid-based methods is that the number of clusters needs to be known in advance (it is a parameter of the methods). However, we can determine the number of clusters by its Internal validation (index). Basic steps are based on that we compute some internal validation index with many ( K ) and we choose ( K ) with the best index value.

Many indexes are there…

Silhouette
Davies-Bouldin index
Dunn index
etc.

However, every index has similar characteristics:

\[\frac{within-cluster-similarity}{between-clusters-similarity} .\]

so, it is the ratio of the average distances in clusters and between clusters.

Elbow diagram

The Elbow diagram is a simple method (rule) how to determine the number of clusters - we compute the internal index with a set of K and choose K where positive change is largest.

So for example, I chose the Davies-Bouldin index implemented in the clusterCrit package. For our simple dataset, I will generate clusterings with 2-6 number of clusters and compute the index.

library(clusterCrit)
 
km_res_k <- lapply(2:6, function(i) kmeans(data_example[, .(x, y)], i)$cluster)
km_res_k

## [[1]]
##  [1] 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 1 2
## 
## [[2]]
##  [1] 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 3 2 1
## 
## [[3]]
##  [1] 1 1 1 1 1 1 1 1 1 1 4 4 4 4 4 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 2 4 3
## 
## [[4]]
##  [1] 5 5 5 5 5 5 5 5 5 5 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 4 1 3
## 
## [[5]]
##  [1] 1 1 1 1 1 1 1 5 5 1 6 6 6 6 6 6 6 6 6 6 3 3 3 3 3 3 3 3 3 3 2 6 4

db_km <- lapply(km_res_k, function(j) intCriteria(data.matrix(data_example[, .(x, y)]),
                                                  j,
                                                  "Davies_bouldin")$davies_bouldin)
 
ggplot(data.table(K = 2:6, Dav_Boul = unlist(db_km)), aes(K, Dav_Boul)) +
  geom_line() +
  geom_point() +
  theme_bw()

data_example[, class := as.factor(km_res_k[[which.min(c(0,diff(unlist(db_km))))]])]
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw()

We can see that the Elbow diagram rule chose 4 clusters - makes sense to me actually…

We can also try it with PAM - K-medoids.

kmed_res_k <- lapply(2:6, function(i) pam(data_example[, .(x, y)], i)$clustering)
 
db_kmed <- lapply(kmed_res_k, function(j) intCriteria(data.matrix(data_example[, .(x, y)]),
                                                  j,
                                                  "Davies_bouldin")$davies_bouldin)
 
ggplot(data.table(K = 2:6, Dav_Boul = unlist(db_kmed)), aes(K, Dav_Boul)) +
  geom_line() +
  geom_point() +
  theme_bw()

data_example[, class := as.factor(kmed_res_k[[which.min(c(0,diff(unlist(db_km))))]])]
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw()

It is the same result.

Model-based

Model-based clustering methods are based on some probabilistic distribution. It can be:

Gaussian normal distribution
Gamma distribution
Student’s t-distribution
Poisson distribution
etc.

Since we cluster multivariate data, model-based clustering uses Multivariate distributions and a so-called Mixture of models (Mixtures -> clusters). When using clustering with Gaussian normal distribution, we are using the theory of Gaussian Mixture Models (GMM).

GMM

The target is to maximize likelihood: \(L(\boldsymbol{\mu_1}, \dots, \boldsymbol{\mu_k}, \boldsymbol{\Sigma_1}, \dots, \boldsymbol{\Sigma_k} | \boldsymbol{x_1}, \dots, \boldsymbol{x_n}).\) Here, cluster is represented by mean (( \mathbf{\mu} )) and covariance matrix (( \mathbf{\Sigma} )). So not just centroid as in the case of K-means.

This optimization problem is typically solved by the EM algorithm (Expectation Maximization).

Pros and cons:

[+] Ellipsoidal clusters,
[+] Can be parameterized by covariance matrix,
[+] Scale-independent,
[-] Very slow for high-dimensional data,
[-] Can be difficult to understand.

EM algorithm with GMM is implemented in the mclust package. You can optimize various shapes of mixtures (clusters) by the modelNames parameter (check the ?mclustModelNames function for more details).

library(mclust)
res <- Mclust(data_example[, .(x, y)], G = 3, modelNames = "VVV", verbose = FALSE)
 
plot(res, what = "classification")

Pretty interesting red ellipse that was created, but generally clustering is OK.

BIC

The Bayesian Information Criterion (BIC) for choosing the optimal number of clusters can be used with model-based clustering. In the mclust package, you can just add multiple modelNames and it chooses by BIC the best one. We can try also to vary the dependency of covariance matrix ( \mathbf{\Sigma} ).

res <- Mclust(data_example[, .(x, y)], G = 2:6, modelNames = c("VVV", "EEE", "VII", "EII"), verbose = FALSE)
res

## 'Mclust' model object: (EII,6) 
## 
## Available components: 
##  [1] "call"           "data"           "modelName"      "n"              "d"              "G"              "BIC"            "loglik"         "df"             "bic"            "icl"           
## [12] "hypvol"         "parameters"     "z"              "classification" "uncertainty"

plot(res, what = "BIC")

The result:

plot(res, what = "classification")

So, the methodology chose 6 clusters - 3 main groups of data and all 3 anomalies in separate clusters.

Density-based

Density-based clusters are based on maximally connected components of the set of points that lie within some defined distance from some core object.

Methods:

DBSCAN
OPTICS
HDBSCAN
Multiple densities (Multi-density) methods

DBSCAN

In the well-known method DBSCAN, density is defined as neighborhood, where points have to be reachable within a defined distance (( \epsilon ) distance - first parameter of the method), however, clusters must have at least some number of minimal points (second parameter of the method). Points that weren’t connected with any cluster and did not pass the minimal points criterion are marked as noise (outliers).

Pros and cons:

[+] Extracts automatically outliers,
[+] Fast to compute,
[+] Can find clusters of arbitrary shapes,
[+] The number of clusters is determined automatically based on data,
[-] Parameters (( \epsilon ), minPts) must be set by a practitioner,
[-] Possible problem with neighborhoods - can be connected.

DBSCAN is implemented in the same named function and package, so let’s try it.

library(dbscan)
 
res <- dbscan(data_example[, .(x, y)], eps = 0.4, minPts = 5)
table(res$cluster)

## 
##  0  1  2  3 
##  3 10 10 10

data_example[, class := as.factor(res$cluster)]
levels(data_example$class)[1] <- c("Noise")
 
ggplot(data_example, aes(x, y, color = class, shape = class)) +
  geom_point(alpha = 0.75, size = 8) +
  theme_bw() +
  scale_shape_manual(values = c(3,16,17,18))

We can see that DBSCAN found 3 clusters and 3 outliers correctly when parameters are wisely chosen.

Bananas - DBSCAN result

To demonstrate the strength of DBSCAN, researchers created many dummy artificial datasets, which are many times called bananas.

bananas <- fread("_rmd/t7.10k.dat")
db_res <- dbscan(bananas, eps = 10, minPts = 15)
 
data_all <- data.table(bananas, class = as.factor(db_res$cluster))
 
library(ggsci)
ggplot(data_all, aes(V1, V2, color = class, shape = class)) +
  geom_point(alpha = 0.75) +
  scale_color_d3() +
  scale_shape_manual(values = c(3, rep(16, 9))) +
  theme_bw()

Bananas - K-means result

km_res <- kmeans(bananas, 9)
data_all[, class := as.factor(km_res$cluster)]
 
ggplot(data_all, aes(V1, V2, color = class)) +
  geom_point(alpha = 0.75) +
  scale_color_d3() +
  theme_bw()

K-means here is not a good choice obviously…but these datasets are far from real-world either.

Spectral clustering

Spectral clustering methods are based on the spectral decomposition of data, so the creation of eigen vectors and eigen values.

Steps:

N = number of data, d = dimension of data,
( \mathbf{A} ) = affinity matrix, ( A_{ij} = \exp(- (data_i - data_j)^2 / (2*\sigma^2) ) ) - N by N matrix,
( \mathbf{D} ) = diagonal matrix whose (i,i)-element is the sum of ( \mathbf{A} ) i-th row - N by N matrix,
( \mathbf{L} ) = ( \mathbf{D}^{-1/2} \mathbf{A} \mathbf{D}^{-1/2} ) - N by N matrix,
( \mathbf{X} ) = union of k largest eigenvectors of ( \mathbf{L} ) - N by k matrix,
Renormalising each of ( \mathbf{X} ) rows to have unit length - N by k matrix,
Run K-means algorithm on ( \mathbf{X} ).

Typical use case for spectral clustering

We will try spectral clustering on the Spirals artificial dataset.

data_spiral <- fread("_rmd/data_spiral.csv")
 
ggplot(data_spiral, aes(x, y, color = as.factor(label), shape = as.factor(label))) +
  geom_point(size = 2) +
  theme_bw()

Spectral clustering is implemented in the kernlab package and specc function.

library(kernlab)
 
res <- specc(data.matrix(data_spiral[, .(x, y)]), centers = 3)
 
data_spiral[, class := as.factor(res)]
 
ggplot(data_spiral, aes(x, y, color = class, shape = class)) +
  geom_point(size = 2) +
  theme_bw()

Let’s it try on more advanced data - compound data.

data_compound <- fread("_rmd/data_compound.csv")
 
ggplot(data_compound, aes(x, y, color = as.factor(label), shape = as.factor(label))) +
  geom_point(size = 2) +
  theme_bw()

res <- specc(data.matrix(data_compound[, .(x, y)]), centers = 6)
 
data_compound[, class := as.factor(res)]
 
ggplot(data_compound, aes(x, y, color = class, shape = class)) +
  geom_point(size = 2) +
  theme_bw()

This is not a good result, let’s try DBSCAN.

db_res <- dbscan(data.matrix(data_compound[, .(x, y)]), eps = 1.4, minPts = 5)
# db_res
 
data_compound[, class := as.factor(db_res$cluster)]
 
ggplot(data_compound, aes(x, y, color = class, shape = class)) +
  geom_point(size = 2) +
  theme_bw()

Again, the nice result for DBSCAN on the artificial dataset.

Hierarchical clustering

The result of a hierarchical clustering is a dendrogram. The dendrogram can be cut at any height to form a partition of the data into clusters. How data points are connected in the dendrogram has multiple possible ways (linkages) and criteria:

Single-linkage
Complete-linkage
Average-linkage
Centroid-linkage
Ward’s minimum variance method
etc.

Criteria:

single-linkage: ( \min { d(a,b):a\in A, b\in B } )
complete-linkage: ( \max { d(a,b):a\in A, b\in B } )
average-linkage: ( \frac{1}{ A B }\sum_{a\in A}\sum_{b\in B}d(a,b) )
centroid-linkage: ( c_t - c_s ), where ( c_s ) and ( c_t ) are the centroids of clusters ( s ) and ( t ).

where ( d(a,b) ) is the distance between points ( a ) and ( b ).

IRIS dataset use case

Let’s try hierarchical clustering on the IRIS dataset.

ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
  geom_point(alpha = 0.8, size = 5) +
  theme_bw()

Single linkage:

library(ggdendro)
library(dendextend)
 
data_m <- iris[,-5]
 
hie_single <- hclust(dist(data_m), method = "single")
dend <- as.dendrogram(hie_single)
dend <- dend %>% set("branches_k_color", k = 3) %>%
  set("branches_lwd", 1.2) %>% 
  set("labels", rep(c("set", "ver", "vir"), each = 50)) %>%
  set("labels_colors", rep(c("red", "green", "blue"), each = 50)) %>%
  set("labels_cex", 0.6)
ggd1 <- as.ggdend(dend)
ggplot(ggd1)

Complete linkage:

hie_complete <- hclust(dist(data_m), method = "complete")
dend <- as.dendrogram(hie_complete)
dend <- dend %>% set("branches_k_color", k = 3) %>%
  set("branches_lwd", 1.2) %>% 
  set("labels", rep(c("set", "ver", "vir"), each = 50)) %>%
  set("labels_colors", rep(c("red", "green", "blue"), each = 50)) %>%
  set("labels_cex", 0.6)
ggd1 <- as.ggdend(dend)
ggplot(ggd1)

Average linkage:

hie_ave <- hclust(dist(data_m), method = "average")
dend <- as.dendrogram(hie_ave)
dend <- dend %>% set("branches_k_color", k = 3) %>% 
  set("branches_lwd", 1.2) %>% 
  set("labels", rep(c("set", "ver", "vir"), each = 50)) %>%
  set("labels_colors", rep(c("red", "green", "blue"), each = 50)) %>%
  set("labels_cex", 0.6)
ggd1 <- as.ggdend(dend)
ggplot(ggd1)

Let’s compute the precision of these three clusterings with the clusterCrit package:

extCriteria(as.integer(iris[,5]), cutree(hie_single, 3), crit = "Precision")

## $precision
## [1] 0.5985951

extCriteria(as.integer(iris[,5]), cutree(hie_complete, 3), crit = "Precision")

## $precision
## [1] 0.7225295

extCriteria(as.integer(iris[,5]), cutree(hie_ave, 3), crit = "Precision")

## $precision
## [1] 0.8191682

The best results were obtained with average linkage with precision of 81.9%.

Connected data

I have prepared for you the last use case for most shown methods where data (and clusters) are closely connected, so the closest scenario of real data.

set.seed(5)
library(MASS)
 
data_connected <- as.data.table(rbind(
  mvrnorm(220, mu = c(3.48, 3.4), Sigma = matrix(c(0.005, -0.015, -0.01, 0.09), nrow = 2)),
  mvrnorm(280, mu = c(3.8, 3.8), Sigma = matrix(c(0.05, 0, 0, 0.05), nrow = 2)),
  mvrnorm(220, mu = c(3.85, 2.9), Sigma = matrix(c( 0.1, 0.03, 0.03, 0.017), nrow = 2))
  ))
 
setnames(data_connected, c("V1", "V2"), c("x", "y"))
 
ggplot(data_connected, aes(x, y)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

DBSCAN - result for connected data

Chosen parameters are ( \epsilon = 0.08 ), ( minPts = 18 ).

db_res <- dbscan(data_connected, eps = 0.08, minPts = 18)

data_all <- data.table(data_connected, class = as.factor(db_res$cluster))
 
ggplot(data_all, aes(x, y, color = class)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

The result is quite good enough, where the main three core groups are identified. Let’s change minPts to 10.

db_res <- dbscan(data_connected, eps = 0.08, minPts = 10)
 
data_all <- data.table(data_connected, class = as.factor(db_res$cluster))
 
ggplot(data_all, aes(x, y, color = class)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

We can see a use case where DBSCAN is very sensitive to parameter settings, and you have to be very careful with some automatic settings of these parameters (in your use cases).

K-means - result for connected data

km_res <- kmeans(data_connected, 3)
 
data_all[, class := as.factor(km_res$cluster)]
 
ggplot(data_all, aes(x, y, color = class)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

Nice result to be fair for this simple method.

Gaussian model-based clustering result

m_res <- Mclust(data_connected, G = 3, modelNames = "VVV", verbose = FALSE)
 
data_all[, class := as.factor(m_res$classification)]
 
ggplot(data_all, aes(x, y, color = class)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

Almost perfect result, but due to the normality of sampled data.

Spectral clustering result

res <- specc(data.matrix(data_connected[, .(x, y)]), centers = 3)
 
data_all[, class := as.factor(res)]
 
ggplot(data_all, aes(x, y, color = class)) +
  geom_point(alpha = 0.75, size = 2) +
  theme_bw()

Very nice result again!

Other types of clustering methods

Other types of clustering methods that were not covered in this blog post are:

Grid-based
Subspace clustering
Multi-view clustering
Based on artificial neural networks (e.g. SOM)
Consensus (ensemble) clustering
Data stream(s) clustering
etc.

Conclusions

We have many types of clustering methods
Different datasets need different clustering methods
Automatic determination of a number of clusters can be tricky
Real datasets are usually connected - density-based methods can fail
Outliers (anomalies) can significantly influence clustering results - the solution is to preprocess the data or use density-based clustering
Some methods are not suited for large (or high-dimensional) datasets - model-based or spectral clustering
Some methods are not suited for non-convex clusters - K-means, basic hierarchical clustering

Multivariate Regression Ensemble Models for Errors Prediction

Wed, 29 Nov 2023 00:00:00 +0000

In the last blog post about Multistep forecasting losses, I showed the usage of the fantastic method adam from the smooth R package on household electricity consumption data, and compared it with benchmarks.

Since I computed predictions from 10 methods/models for a long period of time, it would be nice to create some ensemble models for precise prediction for our household consumption data. For that purpose, it would be great to predict for example future errors of these methods. It is used in some known ensemble methods, which are not direct about stacking. Predicting errors can be beneficial for prediction weighting or for predicting the rank of methods (i.e. best one prediction). For the sake of learning something new, I will try multivariate regression models, so learning from multiple targets at once. At least, it has the benefit of simplicity, that we need only one model for all base prediction models.

What I will show you in this post:

Prediction of forecasting errors (absolute residuals) of simple exponential smoothing methods.
Usage of multivariate multiple linear regression benchmarks.
Check of right rank prediction of forecasting methods.
Catboost MultiRMSE capability and evaluation if it is more powerful than linear models.
Computation of two types of ensemble predictions from predicted errors.

Simple forecasting methods error prediction

In the beginning, we need to load the required packages, be aware that catboost has to be installed by the devtools package in R.

library(data.table)
library(lubridate)
library(TSrepr)
library(ggplot2)
library(dygraphs)
library(glmnet)
# devtools::install_url('https://github.com/catboost/catboost/releases/download/v1.2.2/catboost-R-Windows-1.2.2.tgz')
library(catboost)

I will use predictions and errors from a previous blog post, you can download them from my GitHub repository.

load("_rmd/data_household_predictions.Rdata")
data_predictions_all

##                   Date_Time Load_real Load_predicted    model
##      1: 2023-01-30 00:00:00     0.274     -0.7679345  STL+ETS
##      2: 2023-01-30 00:15:00     0.363     -0.7959601  STL+ETS
##      3: 2023-01-30 00:30:00     0.342     -0.7443988  STL+ETS
##      4: 2023-01-30 00:45:00     0.391     -0.8461708  STL+ETS
##      5: 2023-01-30 01:00:00     0.230     -0.8708582  STL+ETS
##     ---                                                      
## 205436: 2023-08-31 22:45:00     0.080      0.4030999 ADAM-GPL
## 205437: 2023-08-31 23:00:00     0.039      0.2060178 ADAM-GPL
## 205438: 2023-08-31 23:15:00     0.087      0.2489654 ADAM-GPL
## 205439: 2023-08-31 23:30:00     0.080      0.1719251 ADAM-GPL
## 205440: 2023-08-31 23:45:00     0.040      0.4710469 ADAM-GPL

We will model absolute errors of predictions:

data_predictions_all[, Error := abs(Load_real - Load_predicted)]

To be able to model all method’s predictions at once, we need to cast predictions and errors to wide form.

data_predictions_all_casted <- dcast(data_predictions_all,
                                     formula = Date_Time ~ model,
                                     value.var = c("Load_predicted", "Error"))
 
setnames(data_predictions_all_casted,
         colnames(data_predictions_all_casted),
         gsub("-", "_", colnames(data_predictions_all_casted)))
setnames(data_predictions_all_casted,
         colnames(data_predictions_all_casted),
         gsub("\\+", "_", colnames(data_predictions_all_casted)))
 
str(data_predictions_all_casted)

## Classes 'data.table' and 'data.frame':	20544 obs. of  21 variables:
##  $ Date_Time                : POSIXct, format: "2023-01-30 00:00:00" "2023-01-30 00:15:00" ...
##  $ Load_predicted_ADAM_GPL  : num  0.658 0.679 0.447 0.366 0.288 ...
##  $ Load_predicted_ADAM_GTMSE: num  0.663 0.68 0.449 0.373 0.296 ...
##  $ Load_predicted_ADAM_MAE  : num  0.324 0.462 0.34 0.349 0.29 ...
##  $ Load_predicted_ADAM_MAEh : num  0.545 0.566 0.334 0.253 0.175 ...
##  $ Load_predicted_ADAM_MSCE : num  0.676 0.761 0.603 0.597 0.466 ...
##  $ Load_predicted_ADAM_MSE  : num  0.276 0.394 0.257 0.262 0.246 ...
##  $ Load_predicted_ADAM_MSEh : num  0.662 0.681 0.452 0.377 0.299 ...
##  $ Load_predicted_ADAM_TMSE : num  0.663 0.68 0.449 0.373 0.296 ...
##  $ Load_predicted_STL_ARIMA : num  -0.386 -0.412 -0.406 -0.482 -0.529 ...
##  $ Load_predicted_STL_ETS   : num  -0.768 -0.796 -0.744 -0.846 -0.871 ...
##  $ Error_ADAM_GPL           : num  0.3839 0.316 0.1048 0.0248 0.0576 ...
##  $ Error_ADAM_GTMSE         : num  0.389 0.3168 0.1067 0.0183 0.0659 ...
##  $ Error_ADAM_MAE           : num  0.0504 0.09894 0.00155 0.04186 0.06019 ...
##  $ Error_ADAM_MAEh          : num  0.27104 0.20306 0.00819 0.1378 0.0554 ...
##  $ Error_ADAM_MSCE          : num  0.402 0.398 0.261 0.206 0.236 ...
##  $ Error_ADAM_MSE           : num  0.00248 0.03124 0.08472 0.12901 0.01597 ...
##  $ Error_ADAM_MSEh          : num  0.3884 0.3179 0.1097 0.0137 0.0692 ...
##  $ Error_ADAM_TMSE          : num  0.389 0.3168 0.1067 0.0183 0.0659 ...
##  $ Error_STL_ARIMA          : num  0.66 0.775 0.748 0.873 0.759 ...
##  $ Error_STL_ETS            : num  1.04 1.16 1.09 1.24 1.1 ...
##  - attr(*, ".internal.selfref")=<externalptr> 
##  - attr(*, "sorted")= chr "Date_Time"

Since we will train the regression model, there can be added also other helpful features. Let’s define helping daily and weekly seasonality features in the form of Sinus and Cosines. You can add also other features like holidays and weather parameters if it makes sense for your case.

period <- 96
data_predictions_all_casted[, Day_period := 1:.N, by = .(Date = lubridate::date(Date_Time))]
data_predictions_all_casted[, S_day := (sin(2*pi*(Day_period/period)) + 1)/2]
data_predictions_all_casted[, C_day := (cos(2*pi*(Day_period/period)) + 1)/2]
data_predictions_all_casted[, Day_period := NULL]
 
data_predictions_all_casted[, Wday := lubridate::wday(Date_Time, label = F,
                                                      week_start = getOption("lubridate.week.start", 1))]
  
data_predictions_all_casted[, S_week := (sin(2*pi*(Wday/7)) + 1)/2]
data_predictions_all_casted[, C_week := (cos(2*pi*(Wday/7)) + 1)/2]
data_predictions_all_casted[, Wday := NULL]

Let’s split the train and test set: the first 170 days of predictions will go to the train part, rest of the 44 days for the testing (evaluation) part.

data_predictions_all_casted_train <- copy(data_predictions_all_casted[1:(96*170)])
data_predictions_all_casted_test <- copy(data_predictions_all_casted[((96*170)+1):.N])
all_cols <- colnames(data_predictions_all_casted)
targets <- all_cols[grepl("Error", all_cols)]
targets

##  [1] "Error_ADAM_GPL"   "Error_ADAM_GTMSE" "Error_ADAM_MAE"   "Error_ADAM_MAEh" 
##  [5] "Error_ADAM_MSCE"  "Error_ADAM_MSE"   "Error_ADAM_MSEh"  "Error_ADAM_TMSE" 
##  [9] "Error_STL_ARIMA"  "Error_STL_ETS"

features <- all_cols[!all_cols %in% c("Date_Time", targets)]
features

##  [1] "Load_predicted_ADAM_GPL"   "Load_predicted_ADAM_GTMSE"
##  [3] "Load_predicted_ADAM_MAE"   "Load_predicted_ADAM_MAEh" 
##  [5] "Load_predicted_ADAM_MSCE"  "Load_predicted_ADAM_MSE"  
##  [7] "Load_predicted_ADAM_MSEh"  "Load_predicted_ADAM_TMSE" 
##  [9] "Load_predicted_STL_ARIMA"  "Load_predicted_STL_ETS"   
## [11] "S_day"                     "C_day"                    
## [13] "S_week"                    "C_week"

Let’s see our error targets:

ggplot(data_predictions_all,
       aes(Date_Time, Error)) +
  facet_wrap(~model, ncol = 2) +
  geom_line() +
  theme_bw()

Multivariate Linear Regression Model

As a benchmark, as opposed to catboost, we will try a simple multivariate multiple linear regression model by the base lm function. You just need to use the cbind function inside the formula to incorporate multiple targets in the model.

mmlm <- lm(as.formula(paste0("cbind(", paste(targets, collapse = ", "), ") ~ .")),
           data = data_predictions_all_casted_train[, .SD, .SDcols = c(targets, features)])
 
# summary(mmlm)
# manova(mmlm)
# confint(mmlm)
# coef(mmlm)

Summaries of the model would be very large to print here, so I commented on the most useful functions to do your analysis of the trained model with summary, manova, coef, and confint.

Now, let’s predict errors on our selected test set and compute directly prediction errors and Rank accuracy.

mmlm_predicted <- predict(mmlm, data_predictions_all_casted_test[, .SD, .SDcols = c(features)])
dt_mmlm_predicted <- copy(data_predictions_all_casted_test[, .SD, .SDcols = c("Date_Time", targets)])
dt_mmlm_predicted[, (paste0(targets, "_prediction")) := as.data.table(mmlm_predicted)]
 
dt_mmlm_predicted_melt <- copy(melt(dt_mmlm_predicted,
                                    id.vars = "Date_Time",
                                    measure.vars = list(real = targets,
                                                        predicted = paste0(targets, "_prediction")),
                                    variable.name = "model",
                                    variable.factor = F))
 
dt_mmlm_predicted_melt[data.table(model = as.character(1:10),
                                  model_name = targets),
                       on = .(model),
                       model := i.model_name]
 
setorder(dt_mmlm_predicted_melt, Date_Time, real)
dt_mmlm_predicted_melt[, Rank := 1:.N, by = .(Date_Time)]
setorder(dt_mmlm_predicted_melt, Date_Time, predicted)
dt_mmlm_predicted_melt[, Rank_pred := 1:.N, by = .(Date_Time)]
 
dt_mmlm_predicted_melt[, .(RMSE = round(rmse(real, predicted), 3),
                           MAE = round(mae(real, predicted), 3),
                           MdAE = round(mdae(real, predicted), 3),
                           Rank_error = round(mae(Rank, Rank_pred), 3),
                           Rank_1_accuracy = round(.SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N], 3),
                           Rank_1_cases = .SD[Rank == 1, .N]),
                       by  = .(model)][order(-Rank_1_cases)]

##                model  RMSE   MAE  MdAE Rank_error Rank_1_accuracy Rank_1_cases
##  1:    Error_STL_ETS 0.476 0.324 0.239      3.149           0.314          892
##  2:  Error_ADAM_MSCE 0.429 0.276 0.191      2.766           0.279          634
##  3:  Error_ADAM_MAEh 0.443 0.289 0.207      2.768           0.367          621
##  4:  Error_STL_ARIMA 0.459 0.308 0.228      2.976           0.223          588
##  5:   Error_ADAM_MAE 0.453 0.307 0.226      3.474           0.466          584
##  6:   Error_ADAM_MSE 0.448 0.305 0.224      3.303           0.011          379
##  7:  Error_ADAM_MSEh 0.420 0.270 0.192      1.985           0.009          212
##  8:   Error_ADAM_GPL 0.415 0.266 0.190      2.106           0.097          185
##  9: Error_ADAM_GTMSE 0.419 0.267 0.188      2.045           0.012           82
## 10:  Error_ADAM_TMSE 0.420 0.269 0.191      2.060           0.000           47

dt_mmlm_predicted_melt[, .(RMSE = rmse(real, predicted),
                           MAE = mae(real, predicted),
                           MdAE = mdae(real, predicted),
                           Rank_error = mae(Rank, Rank_pred),
                           Rank_1_accuracy = .SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N])]

##         RMSE       MAE      MdAE Rank_error Rank_1_accuracy
## 1: 0.4387276 0.2880984 0.2051204   2.662926       0.2634943

We can see that the best MAEs have GTMSE, TMSE, and GPL losses. On the other hand, best Rank estimation has MSEh loss and best first Rank estimation accuracy has simple MAE loss method. In general, we miss Rank on average by 2.6 from 10 possible ranks.

Let’s see error predictions from four of our methods.

ggplot(dt_mmlm_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
       aes(Date_Time, predicted, color = "predicted error")) +
  facet_wrap(~model) +
  geom_line(data = dt_mmlm_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
            aes(Date_Time, real, color = "real error")) +
  geom_line(alpha = 0.7, linewidth = 0.6) +
  scale_color_manual(values = c("red", "black")) +
  theme_bw() +
  theme(legend.position="bottom")

At first sight, it can be seen that we can nicely hit low and medium magnitudes of errors. Again, as shown in my previous post, higher values can’t be predicted.

Shrinkage - LASSO with full interactions

As the second multivariate model benchmark, I will try LASSO (glmnet) shrinkage capability and use all possible interactions to model (by using .^2 in the formula).

lambdas <- 10^seq(3, -2, by = -.1)
 
data_with_interactions <- model.matrix(~ . + .^2,
                                       data = data_predictions_all_casted_train[, .SD,
                                                                                .SDcols = c(features)])
 
mlassom <- cv.glmnet(x = data_with_interactions,
                     y = as.matrix(data_predictions_all_casted_train[, .SD, .SDcols = c(targets)]),
                     family = "mgaussian",
                     alpha = 1,
                     lambda = lambdas,
                     intercept = T,
                     standardize = T)

To check estimated coefficients, we can use the predict method.

coefs <- predict(mlassom, type = "coefficients",
                 s = c(mlassom$lambda.min))
 
mlassom$lambda.min

## [1] 0.01

Let’s predict errors on the test set and compute prediction errors.

mlassom_prediction <- predict(mlassom,
                              type = "response",
                              s = mlassom$lambda.min,
                              newx = model.matrix(~ . + .^2,
                                                  data = data_predictions_all_casted_test[, .SD,
                                                                                          .SDcols = c(features)]))
 
dt_mlassom_predicted <- copy(data_predictions_all_casted_test[, .SD, .SDcols = c("Date_Time", targets)])
dt_mlassom_predicted[, (paste0(targets, "_prediction")) := as.data.table(mlassom_prediction[,,1])]
 
dt_mlassom_predicted_melt <- copy(melt(dt_mlassom_predicted,
                                       id.vars = "Date_Time",
                                       measure.vars = list(real = targets,
                                                           predicted = paste0(targets, "_prediction")),
                                       variable.name = "model",
                                       variable.factor = F))
 
dt_mlassom_predicted_melt[data.table(model = as.character(1:10),
                                     model_name = targets),
                          on = .(model),
                          model := i.model_name]
 
setorder(dt_mlassom_predicted_melt, Date_Time, real)
dt_mlassom_predicted_melt[, Rank := 1:.N, by = .(Date_Time)]
setorder(dt_mlassom_predicted_melt, Date_Time, predicted)
dt_mlassom_predicted_melt[, Rank_pred := 1:.N, by = .(Date_Time)]
 
dt_mlassom_predicted_melt[, .(RMSE = round(rmse(real, predicted), 3),
                              MAE = round(mae(real, predicted), 3),
                              MdAE = round(mdae(real, predicted), 3),
                              Rank_error = round(mae(Rank, Rank_pred), 3),
                              Rank_1_accuracy = round(.SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N], 3),
                              Rank_1_cases = .SD[Rank == 1, .N]),
                          by  = .(model)][order(-Rank_1_cases)]

##                model  RMSE   MAE  MdAE Rank_error Rank_1_accuracy Rank_1_cases
##  1:    Error_STL_ETS 0.466 0.325 0.257      3.640           0.151          892
##  2:  Error_ADAM_MSCE 0.427 0.277 0.190      2.956           0.341          634
##  3:  Error_ADAM_MAEh 0.439 0.290 0.211      2.689           0.243          621
##  4:  Error_STL_ARIMA 0.455 0.313 0.239      3.153           0.105          588
##  5:   Error_ADAM_MAE 0.447 0.315 0.240      3.208           0.158          584
##  6:   Error_ADAM_MSE 0.439 0.306 0.229      3.313           0.003          379
##  7:  Error_ADAM_MSEh 0.414 0.263 0.185      2.528           0.019          212
##  8:   Error_ADAM_GPL 0.410 0.261 0.182      2.708           0.103          185
##  9: Error_ADAM_GTMSE 0.414 0.261 0.179      2.502           0.134           82
## 10:  Error_ADAM_TMSE 0.415 0.264 0.184      2.608           0.064           47

dt_mlassom_predicted_melt[, .(RMSE = rmse(real, predicted),
                              MAE = mae(real, predicted),
                              MdAE = mdae(real, predicted),
                              Rank_error = mae(Rank, Rank_pred),
                              Rank_1_accuracy = .SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N])]

##         RMSE      MAE      MdAE Rank_error Rank_1_accuracy
## 1: 0.4328982 0.287333 0.2033996    2.93054       0.1642992

We can see that the best MAEs have the same methods as with MMLM. On the other hand, best Rank estimation has GTMSE loss and best first Rank estimation accuracy has MSCE multistep loss method. In general, we miss Rank on average by 2.9 from 10 possible ranks, so worse by 0.3 as opposed to MMLM. We can say that LASSO didn’t much help to our error modeling.

But, let’s see LASSO error predictions from four of our methods.

ggplot(dt_mlassom_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
       aes(Date_Time, predicted, color = "predicted error")) +
  facet_wrap(~model) +
  geom_line(data = dt_mlassom_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
            aes(Date_Time, real, color = "real error")) +
  geom_line(alpha = 0.7, linewidth = 0.6) +
  scale_color_manual(values = c("red", "black")) +
  theme_bw() +
  theme(legend.position="bottom")

Catboost MultiRMSE

The final multivariate regression method used will be Catboost gradient boosting trees with Multi-target regression loss - MultiRMSE, you can check documentation for this loss here: https://catboost.ai/en/docs/concepts/loss-functions-multiregression.

Let’s define the training method with early stopping based on the validation set and directly train on our dataset.

train_catboost_multirmse <- function(data, target, ncores, valid_ratio) {
  
  data <- na.omit(data)
  
  n_rows <- nrow(data)
  idx <- 1:n_rows
  
  end_ratio <- 0.02
  train_idx <- c(idx[1:floor(n_rows*(1 - (end_ratio + valid_ratio)))],
                 idx[(floor(n_rows*(1-end_ratio)) + 1):n_rows])
  valid_idx <- c(idx[(floor(n_rows*(1 - (end_ratio + valid_ratio)))+1):floor(n_rows*(1-end_ratio))])
  
  train_pool <- catboost::catboost.load_pool(as.data.frame(data[train_idx, !target, with = F]),
                                             label = as.matrix(data[train_idx, mget(target)]))
  
  valid_pool <- catboost::catboost.load_pool(as.data.frame(data[valid_idx, !target, with = F]),
                                             label = as.matrix(data[valid_idx, mget(target)]))
  
  fit_params <- list(iterations = 3000,
                     learning_rate = 0.015,
                     depth = 12,
                     loss_function = 'MultiRMSE',
                     langevin = TRUE,
                     min_data_in_leaf = 5,
                     eval_metric = "MultiRMSE",
                     metric_period = 50,
                     early_stopping_rounds = 60,
                     rsm = 0.75,
                     l2_leaf_reg = 1,
                     train_dir = "train_dir",
                     logging_level = "Verbose",
                     boosting_type = "Plain",
                     grow_policy = "Lossguide",
                     score_function = "L2",
                     bootstrap_type = "Bayesian",
                     bagging_temperature = 1,
                     use_best_model = T,
                     allow_writing_files = F,
                     thread_count = ncores)
  
  m_cat <- catboost::catboost.train(learn_pool = train_pool,
                                    test_pool = valid_pool,
                                    params = fit_params)
  
  return(m_cat)
  
}
 
m_catboost_multirmse <- train_catboost_multirmse(data = data_predictions_all_casted_train[, .SD, .SDcols = c(targets, features)],
                                                 target = targets,
                                                 ncores = 4,
                                                 valid_ratio = 0.05)

## Warning: Overfitting detector is active, thus evaluation metric is calculated on every iteration. 'metric_period' is ignored for evaluation metric.
## 0:	learn: 1.8651752	test: 1.6317912	best: 1.6317912 (0)	total: 7.09ms	remaining: 21.3s
## 50:	learn: 1.7805225	test: 1.4486824	best: 1.4486824 (50)	total: 422ms	remaining: 24.4s
## 100:	learn: 1.7326169	test: 1.3486589	best: 1.3486589 (100)	total: 860ms	remaining: 24.7s
## 150:	learn: 1.7030793	test: 1.2922393	best: 1.2922393 (150)	total: 1.35s	remaining: 25.5s
## 200:	learn: 1.6875372	test: 1.2686592	best: 1.2686592 (200)	total: 1.82s	remaining: 25.3s
## 250:	learn: 1.6747041	test: 1.2518136	best: 1.2518136 (250)	total: 2.35s	remaining: 25.8s
## 300:	learn: 1.6645811	test: 1.2407228	best: 1.2407228 (300)	total: 2.9s	remaining: 26s
## 350:	learn: 1.6557448	test: 1.2312354	best: 1.2312354 (350)	total: 3.5s	remaining: 26.4s
## 400:	learn: 1.6464796	test: 1.2225415	best: 1.2225415 (400)	total: 4.17s	remaining: 27s
## 450:	learn: 1.6404967	test: 1.2173237	best: 1.2173036 (449)	total: 4.79s	remaining: 27s
## 500:	learn: 1.6353707	test: 1.2138953	best: 1.2138953 (500)	total: 5.42s	remaining: 27s
## 550:	learn: 1.6321053	test: 1.2113879	best: 1.2113879 (550)	total: 5.96s	remaining: 26.5s
## 600:	learn: 1.6273276	test: 1.2084719	best: 1.2083969 (599)	total: 6.6s	remaining: 26.4s
## 650:	learn: 1.6235998	test: 1.2067629	best: 1.2067526 (648)	total: 7.22s	remaining: 26s
## 700:	learn: 1.6207368	test: 1.2056776	best: 1.2056776 (700)	total: 7.78s	remaining: 25.5s
## 750:	learn: 1.6178637	test: 1.2046009	best: 1.2045980 (747)	total: 8.38s	remaining: 25.1s
## 800:	learn: 1.6151604	test: 1.2039642	best: 1.2039435 (796)	total: 8.99s	remaining: 24.7s
## 850:	learn: 1.6122595	test: 1.2028463	best: 1.2028463 (850)	total: 9.6s	remaining: 24.2s
## 900:	learn: 1.6101196	test: 1.2020336	best: 1.2019819 (890)	total: 10.2s	remaining: 23.7s
## 950:	learn: 1.6073753	test: 1.2011880	best: 1.2011371 (948)	total: 10.8s	remaining: 23.3s
## 1000:	learn: 1.6052842	test: 1.2006492	best: 1.2006411 (999)	total: 11.4s	remaining: 22.8s
## 1050:	learn: 1.6039241	test: 1.2001930	best: 1.2001853 (1049)	total: 12s	remaining: 22.2s
## 1100:	learn: 1.6028500	test: 1.1999358	best: 1.1999358 (1100)	total: 12.5s	remaining: 21.5s
## 1150:	learn: 1.6012678	test: 1.1992978	best: 1.1992978 (1150)	total: 13.2s	remaining: 21.2s
## 1200:	learn: 1.5997241	test: 1.1989927	best: 1.1989927 (1200)	total: 13.8s	remaining: 20.7s
## 1250:	learn: 1.5984334	test: 1.1989688	best: 1.1989617 (1248)	total: 14.5s	remaining: 20.3s
## 1300:	learn: 1.5969307	test: 1.1986201	best: 1.1985152 (1278)	total: 15.2s	remaining: 19.9s
## 1350:	learn: 1.5948609	test: 1.1986032	best: 1.1985116 (1314)	total: 15.9s	remaining: 19.4s
## Stopped by overfitting detector  (60 iterations wait)
## 
## bestTest = 1.198511627
## bestIteration = 1314
## 
## Shrink model to first 1315 iterations.

m_catboost_multirmse

## CatBoost model (1315 trees)
## Loss function: MultiRMSE
## Fit to 14 feature(s)

We can check the Feature Importance of the trained model:

fea_imp_catboost <- catboost::catboost.get_feature_importance(m_catboost_multirmse)
fea_imp_catboost <- data.table::data.table(Gain = fea_imp_catboost[,1],
                                           Feature = features)
setorder(fea_imp_catboost, -Gain)
fea_imp_catboost

##           Gain                   Feature
##  1: 26.2825537    Load_predicted_STL_ETS
##  2: 10.2856293   Load_predicted_ADAM_MAE
##  3:  8.9606314   Load_predicted_ADAM_GPL
##  4:  8.5230838  Load_predicted_ADAM_MSCE
##  5:  8.4006334 Load_predicted_ADAM_GTMSE
##  6:  6.5706169  Load_predicted_ADAM_TMSE
##  7:  6.2375988  Load_predicted_STL_ARIMA
##  8:  5.0254951  Load_predicted_ADAM_MSEh
##  9:  4.8948488                     S_day
## 10:  4.7176922   Load_predicted_ADAM_MSE
## 11:  3.8361990  Load_predicted_ADAM_MAEh
## 12:  3.3433404                    C_week
## 13:  2.2428758                     C_day
## 14:  0.6788015                    S_week

STL_ETS and MAE simple loss predictions have the highest importance to the multivariate model.

Let’s predict the test set and compute prediction errors.

predict_multirmse_catboost <- function(data, target, cat_model) {
  
  pred <- catboost::catboost.predict(cat_model,
                                     catboost::catboost.load_pool(as.data.frame(data),
                                                                  label = as.matrix(rep(0, nrow(data)), ncol = length(target))
                                     ),
                                     thread_count = 1)
  
  return(pred)
  
}
 
catboost_prediction <- predict_multirmse_catboost(data = data_predictions_all_casted_test[, .SD, .SDcols = c(features)],
                                                  target = targets,
                                                  cat_model = m_catboost_multirmse)
 
dt_catboost_predicted <- copy(data_predictions_all_casted_test[, .SD, .SDcols = c("Date_Time", targets)])
dt_catboost_predicted[, (paste0(targets, "_prediction")) := as.data.table(catboost_prediction)]
 
dt_catboost_predicted_melt <- copy(melt(dt_catboost_predicted,
                                        id.vars = "Date_Time",
                                        measure.vars = list(real = targets,
                                                            predicted = paste0(targets, "_prediction")),
                                        variable.name = "model",
                                        variable.factor = F))
 
dt_catboost_predicted_melt[data.table(model = as.character(1:10),
                                      model_name = targets),
                           on = .(model),
                           model := i.model_name]
 
setorder(dt_catboost_predicted_melt, Date_Time, real)
dt_catboost_predicted_melt[, Rank := 1:.N, by = .(Date_Time)]
setorder(dt_catboost_predicted_melt, Date_Time, predicted)
dt_catboost_predicted_melt[, Rank_pred := 1:.N, by = .(Date_Time)]
 
dt_catboost_predicted_melt[, .(RMSE = round(rmse(real, predicted), 3),
                               MAE = round(mae(real, predicted), 3),
                               MdAE = round(mdae(real, predicted), 3),
                               Rank_error = round(mae(Rank, Rank_pred), 3),
                               Rank_1_accuracy = round(.SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N], 3),
                               Rank_1_cases = .SD[Rank == 1, .N]),
                           by  = .(model)][order(-Rank_1_cases)]

##                model  RMSE   MAE  MdAE Rank_error Rank_1_accuracy Rank_1_cases
##  1:    Error_STL_ETS 0.467 0.307 0.213      3.428           0.367          892
##  2:  Error_ADAM_MSCE 0.430 0.273 0.178      2.996           0.181          634
##  3:  Error_ADAM_MAEh 0.440 0.280 0.187      2.920           0.072          621
##  4:  Error_STL_ARIMA 0.456 0.291 0.195      3.262           0.315          588
##  5:   Error_ADAM_MAE 0.449 0.305 0.218      3.229           0.166          584
##  6:   Error_ADAM_MSE 0.440 0.293 0.204      3.209           0.021          379
##  7:  Error_ADAM_MSEh 0.415 0.252 0.158      2.458           0.042          212
##  8:   Error_ADAM_GPL 0.411 0.249 0.155      2.626           0.049          185
##  9: Error_ADAM_GTMSE 0.415 0.248 0.153      2.417           0.024           82
## 10:  Error_ADAM_TMSE 0.416 0.251 0.157      2.008           0.000           47

dt_catboost_predicted_melt[, .(RMSE = rmse(real, predicted),
                               MAE = mae(real, predicted),
                               MdAE = mdae(real, predicted),
                               Rank_error = mae(Rank, Rank_pred),
                               Rank_1_accuracy = .SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N])]

##         RMSE       MAE      MdAE Rank_error Rank_1_accuracy
## 1: 0.4343794 0.2748845 0.1785648   2.855114       0.1886837

We can see that the MAE and MdAE metrics were improved by catboost. On the other hand, average Rank estimation and first Rank estimation are not better than with MMLM.

Let’s plot our predicted errors.

ggplot(dt_catboost_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
       aes(Date_Time, predicted, color = "predicted error")) +
  facet_wrap(~model) +
  geom_line(data = dt_catboost_predicted_melt[.(targets[c(1,3,5,9)]), on = .(model)],
            aes(Date_Time, real, color = "real error")) +
  geom_line(alpha = 0.7, linewidth = 0.6) +
  scale_color_manual(values = c("red", "black")) +
  theme_bw() +
  theme(legend.position="bottom")

Models analysis

To have it nicely together, let’s bind all three models’ predictions and compute prediction errors for models and methods.

dt_all_predicted <- rbindlist(list(dt_mmlm_predicted_melt[, method := "mmlm"],
                                   dt_mlassom_predicted_melt[, method := "mlasso"],
                                   dt_catboost_predicted_melt[, method := "catboost"]),
                              use.names = T, fill = T)
 
dt_all_predicted[, Error := real - predicted]
dt_all_predicted[, AE := abs(Error)]
 
dt_all_predicted[, .(RMSE = rmse(real, predicted),
                     MAE = mae(real, predicted),
                     MdAE = mdae(real, predicted),
                     Rank_error = mae(Rank, Rank_pred),
                     Rank_1_accuracy = .SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N]),
                 by = .(method)][order(MAE)]

##      method      RMSE       MAE      MdAE Rank_error Rank_1_accuracy
## 1: catboost 0.4343794 0.2748845 0.1785648   2.855114       0.1886837
## 2:   mlasso 0.4328982 0.2873330 0.2033996   2.930540       0.1642992
## 3:     mmlm 0.4387276 0.2880984 0.2051204   2.662926       0.2634943

dt_all_predicted[, .(RMSE = rmse(real, predicted),
                     MAE = mae(real, predicted),
                     MdAE = mdae(real, predicted),
                     Rank_error = mae(Rank, Rank_pred),
                     Rank_1_accuracy = .SD[Rank_pred == 1 & Rank_pred == Rank, .N] / .SD[Rank == 1, .N]),
                 by = .(model)][order(Rank_error)]

##                model      RMSE       MAE      MdAE Rank_error Rank_1_accuracy
##  1:  Error_ADAM_TMSE 0.4172927 0.2610935 0.1773354   2.225221      0.02127660
##  2: Error_ADAM_GTMSE 0.4161971 0.2587184 0.1728826   2.321023      0.05691057
##  3:  Error_ADAM_MSEh 0.4161620 0.2616851 0.1787479   2.323469      0.02358491
##  4:   Error_ADAM_GPL 0.4119315 0.2586888 0.1757232   2.479640      0.08288288
##  5:  Error_ADAM_MAEh 0.4407660 0.2861382 0.2026681   2.792456      0.22758991
##  6:  Error_ADAM_MSCE 0.4286877 0.2752749 0.1868000   2.906013      0.26708728
##  7:  Error_STL_ARIMA 0.4566267 0.3042826 0.2207566   3.130051      0.21428571
##  8:   Error_ADAM_MSE 0.4423139 0.3010806 0.2195689   3.274779      0.01143360
##  9:   Error_ADAM_MAE 0.4496008 0.3087655 0.2274286   3.303741      0.26312785
## 10:    Error_STL_ETS 0.4697423 0.3186589 0.2340111   3.405540      0.27727952

As already mentioned, the best multivariate regression model based on classical prediction metrics is catboosts MultiRMSE. On the other hand, the best model based on right Rank estimation is simple multivariate linear regression.

Let’s do some basic model analysis and see a boxplot of absolute errors.

ggplot(dt_all_predicted[.(targets[c(1, 3, 5, 9)]), on = .(model)],
       aes(method, AE, fill = method)) +
  geom_boxplot() +
  theme_bw()

Predicted vs. real values scatter plot:

ggplot(dt_all_predicted[.(targets[c(1, 3, 5, 9)]), on = .(model)],
       aes(predicted, real)) +
  facet_wrap(~method, scales = "fixed", ncol = 3) +
  geom_point(alpha = 0.5) +
  geom_abline(intercept = 0, slope = 1, color = "red", 
              linetype = "dashed", linewidth = 1) +
  geom_smooth(alpha = 0.4) +
  labs(title = "Predicted vs Real values") +
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

Errors vs. real values scatter plot:

ggplot(dt_all_predicted[.(targets[c(1, 3, 5, 9)]), on = .(model)],
       aes(Error, real)) +
  facet_wrap(~method, scales = "fixed", ncol = 3) +
  geom_point(alpha = 0.5) +
  geom_smooth(alpha = 0.6) +
  xlab("resid (predicted_value - real_value)") +
  labs(title = "Residual vs Real values") +
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

And heteroscedasticity check, so absolute errors vs. real values:

ggplot(dt_all_predicted[.(targets[c(1, 3, 5, 9)]), on = .(model)],
       aes(real, AE)) +
  facet_wrap(~method, scales = "free") +
  geom_point(alpha = 0.5) +
  geom_smooth(alpha = 0.6) +
  ylab("abs(resid)") +
  labs(title = "Heteroscedasticity check") + 
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

From all the above graphs, we can see that low and medium magnitudes of errors can be nicely predicted, but again prediction of high values of errors is a very difficult task.

We can use nonparametric multiple comparisons test (Nemenyi test) also to decide which error model is best (by Absolute Errors - AE).

tsutils::nemenyi(data.matrix(dcast(dt_all_predicted,
                                   Date_Time + model ~ method,
                                   value.var = "AE")[, !c("Date_Time", "model"), with = F]),
                 plottype = "vmcb")

## Friedman and Nemenyi Tests
## The confidence level is 5%
## Number of observations is 42240 and number of methods is 3
## Friedman test p-value: 0.0000 - Ha: Different
## Critical distance: 0.0161

Catboost is best all the way.

We can also use the Nemenyi test on a question that which of the 10 model errors can be predicted the best.

tsutils::nemenyi(data.matrix(dcast(dt_all_predicted,
                                   Date_Time + method ~ model,
                                   value.var = "AE")[, !c("Date_Time", "method"), with = F]),
                 plottype = "vmcb")

## Friedman and Nemenyi Tests
## The confidence level is 5%
## Number of observations is 12672 and number of methods is 10
## Friedman test p-value: 0.0000 - Ha: Different
## Critical distance: 0.1203

We see that GTMSE and TMSE have the most predictable errors, for non-multistep losses methods (benchmarks) it is more difficult.

Ensemble predictions

Finally, we can now construct some ensemble predictions by our multivariate error model predictions.

Best Rank prediction ensemble

The first method will be very simple, we will use as final ensemble prediction the prediction with the lowest estimated error.

dt_all_predicted[, model := gsub("Error_", "", model)]
data_best_rank_prediction <- copy(dt_all_predicted[, .SD[Rank_pred == 1], by = .(method, Date_Time)])
data_best_rank_prediction[, table(model)] # distribution of used methods

## model
##   ADAM_GPL ADAM_GTMSE   ADAM_MAE  ADAM_MAEh  ADAM_MSCE   ADAM_MSE  ADAM_MSEh 
##        899        880       1513       1613       2302        204        322 
##  ADAM_TMSE  STL_ARIMA    STL_ETS 
##        279       1713       2947

Let’s evaluate ensemble predictions by our error models and also compute metrics for our base predictions for comparison.

data_predictions_all[, model := gsub("-", "_", model)]
data_predictions_all[, model := gsub("\\+", "_", model)]
 
data_best_rank_prediction[data_predictions_all,
                          on = .(model, Date_Time),
                          Load_predicted := i.Load_predicted]
 
data_best_rank_prediction[data_predictions_all,
                          on = .(Date_Time),
                          Load_real := i.Load_real]
 
# original
data_predictions_all[Date_Time %in% data_best_rank_prediction[, unique(Date_Time)],
                     .(RMSE = rmse(Load_real, Load_predicted),
                       MAE = mae(Load_real, Load_predicted),
                       MAAPE = maape(Load_real, Load_predicted)),
                     by = .(model)][order(MAE)]

##          model      RMSE       MAE    MAAPE
##  1:  ADAM_MAEh 0.6153573 0.3915900 79.73346
##  2:  ADAM_MSEh 0.6060004 0.4032142 84.61694
##  3:  ADAM_TMSE 0.6080947 0.4053491 84.76779
##  4: ADAM_GTMSE 0.6094993 0.4085337 85.40032
##  5:   ADAM_GPL 0.6082200 0.4106951 85.66970
##  6:  ADAM_MSCE 0.6251760 0.4153277 85.63160
##  7:  STL_ARIMA 0.6709538 0.4348279 87.92342
##  8:   ADAM_MSE 0.6487472 0.4378956 87.45296
##  9:   ADAM_MAE 0.6550635 0.4386036 87.33271
## 10:    STL_ETS 0.6887292 0.4388718 80.82078

# ensemble
data_best_rank_prediction[, .(RMSE = rmse(Load_real, Load_predicted),
                              MAE = mae(Load_real, Load_predicted),
                              MAAPE = maape(Load_real, Load_predicted)),
                          by = .(method)][order(MAE)]

##      method      RMSE       MAE    MAAPE
## 1: catboost 0.6176298 0.3765020 78.38730
## 2:     mmlm 0.6368562 0.3777519 76.25634
## 3:   mlasso 0.6090476 0.3789960 81.54793

All three ensembles are better than any base prediction based on MAE. Well done!

Let’s plot a graph of the final ensemble predictions:

ggplot(data_best_rank_prediction,
       aes(Date_Time, Load_predicted, color = "predicted load")) +
  facet_wrap(~method, ncol = 1) +
  geom_line(data = data_best_rank_prediction,
            aes(Date_Time, Load_real, color = "real load")) +
  geom_line(alpha = 0.7, linewidth = 0.6) +
  scale_color_manual(values = c("red", "black")) +
  theme_bw() +
  theme(legend.position="bottom")

Catboost doesn’t go that much below zero than the other two.

Weighted average Ensemble

The second ensemble method will be based on weighting the estimated errors. Firstly, we need to normalize all weights (errors) by the Min-max method and compute the sum ratio.

weis <- copy(dt_all_predicted[, .(Wei_m = TSrepr::norm_min_max(-abs(predicted)),
                                  model),
                             by = .(method, Date_Time)])
 
weis_sums <- copy(dt_all_predicted[, .(Wei_sum = sum(TSrepr::norm_min_max(-abs(predicted)))),
                                   by = .(method, Date_Time)])
 
weis[weis_sums,
     Wei_m := Wei_m / i.Wei_sum,
     on = .(method, Date_Time)]

We can use all predictions, but a better way is to remove the bad half of the predictions from the ensemble:

ratio_forec <- 0.5 # 1 to use all 10 predictions
setorder(weis, method, Date_Time, Wei_m)
weis[, Wei_m := replace(Wei_m, 1:floor(.N * ratio_forec), 0),
     by = .(method, Date_Time)]

Now, let’s join weights and predictions and compute final ensemble predictions.

dt_all_predicted_wei_ave <- copy(dt_all_predicted)
dt_all_predicted_wei_ave[weis,
                         Wei_m := i.Wei_m,
                         on = .(model, method, Date_Time)]
 
dt_all_predicted_wei_ave[data_predictions_all,
                         on = .(model, Date_Time),
                         Load_predicted := i.Load_predicted]
 
data_predicted_wei_ave <- copy(dt_all_predicted_wei_ave[,
                                                        .(Load_predicted = weighted.mean(Load_predicted, Wei_m)),
                                                        by = .(method, Date_Time)])

Let’s evaluate them:

data_predicted_wei_ave[data_predictions_all,
                       on = .(Date_Time),
                       Load_real := i.Load_real]
 
data_predicted_wei_ave[, .(RMSE = rmse(Load_real, Load_predicted),
                           MAE = mae(Load_real, Load_predicted),
                           MAAPE = maape(Load_real, Load_predicted)),
                       by = .(method)][order(MAE)]

##      method      RMSE       MAE    MAAPE
## 1:     mmlm 0.6080235 0.3721450 78.36590
## 2: catboost 0.6027960 0.3814034 82.43628
## 3:   mlasso 0.5981348 0.3824002 81.68486

Even better with weighting than the best rank way!

Let’s plot a graph of ensemble predictions:

ggplot(data_predicted_wei_ave,
       aes(Date_Time, Load_predicted, color = "predicted load")) +
  facet_wrap(~method, ncol = 1) +
  geom_line(data = data_predicted_wei_ave,
            aes(Date_Time, Load_real, color = "real load")) +
  geom_line(alpha = 0.7, linewidth = 0.6) +
  scale_color_manual(values = c("red", "black")) +
  theme_bw() +
  theme(legend.position="bottom")

Ultimately, let’s decide which model is best for household electricity consumption prediction:

data_predictions_all_ensembles <- rbindlist(list(data_predictions_all[Date_Time %in% data_best_rank_prediction[, unique(Date_Time)], .(Date_Time, Load_predicted, Load_real, model)],
                                                 data_predicted_wei_ave[, .(Date_Time, Load_predicted, Load_real, model = paste0("ensemble_wei_ave_", method))],
                                                 data_best_rank_prediction[, .(Date_Time, Load_predicted, Load_real, model = paste0("ensemble_best_rank_", method))]))
 
data_predictions_all_ensembles[, AE := abs(Load_real - Load_predicted)]
 
tsutils::nemenyi(data.matrix(dcast(data_predictions_all_ensembles,
                                   Date_Time ~ model,
                                   value.var = "AE")[, !c("Date_Time"), with = F]),
                 plottype = "vmcb")

## Friedman and Nemenyi Tests
## The confidence level is 5%
## Number of observations is 4224 and number of methods is 16
## Friedman test p-value: 0.0000 - Ha: Different
## Critical distance: 0.3549

Weighted average ensemble prediction using the MMLM method is best!

Summary

I showed how easily can be modeled multiple targets with three methods: MMLM, LASSO, and Catboost in R
I trained a model for predicting absolute errors of mostly simple exponential smoothing methods
The multivariate models can nicely predict errors of low-medium magnitude
Again the high errors can not be predicted with those simple models
Catboost showed the best results in regard of absolute error measure
I used predicted errors to create two types of ensemble predictions of electricity consumption
Both ensemble methods showed better results than any original prediction

Multistep horizon loss optimized forecasting with ADAM

Thu, 26 Oct 2023 00:00:00 +0000

Recently, during work on some forecasting task at PowereX, I stumbled upon an interesting improvement in time series forecasting modeling. In general, in regression modeling, we use evaluation/loss metrics based on one step ahead (one value) horizon. But, in many forecasting applications, we are interested in multistep horizon forecasting (e.g. whole 1 day ahead), so some multistep losses would be great to optimize during training of forecasting models. Except obviously in some RNN architectures, this wasn’t easily possible in used libraries/frameworks in the past time.

So, I was very happy to see multistep losses in smooth package and its adam() wrapper and to try it. I already used it in one particular task in my work, and it went successfully to production!

My motivation and what I will show you in this blog post is:

Tribute to the smooth package and its adam() wrapper - especially for its multistep horizon forecasting losses.
Try to use the mentioned losses for forecasting household consumption times series -> very noisy with daily/weekly seasons, no trend.
Show model diagnostic methods with ggplot2 visualizations.

Household consumption data

Firstly, let’s load all the needed packages for forecasting.

library(data.table)
library(lubridate)
library(TSrepr)
library(smooth)
library(forecast)
library(ggplot2)

Next, I will read one household electricity consumption load data. There are data from 2023-01-01 to 2023-08-31. This household heats space and water with electricity - so there are multiple seasonalities that vary during the year.

data_household_consumption <- fread("_Rscripts/household_consumption.csv") # Date_Time in CET, Load in kW
str(data_household_consumption)

## Classes 'data.table' and 'data.frame':	23328 obs. of  2 variables:
##  $ Date_Time: POSIXct, format: "2023-01-01 00:00:00" "2023-01-01 00:15:00" "2023-01-01 00:30:00" "2023-01-01 00:45:00" ...
##  $ Load     : num  0.362 0.622 0.435 0.236 0.322 0.565 0.338 0.467 0.639 0.46 ...
##  - attr(*, ".internal.selfref")=<externalptr>

summary(data_household_consumption)

##    Date_Time                        Load       
##  Min.   :2023-01-01 00:00:00   Min.   :0.0000  
##  1st Qu.:2023-03-02 17:56:15   1st Qu.:0.1140  
##  Median :2023-05-02 11:52:30   Median :0.4440  
##  Mean   :2023-05-02 11:52:30   Mean   :0.7468  
##  3rd Qu.:2023-07-02 05:48:45   3rd Qu.:1.1150  
##  Max.   :2023-08-31 23:45:00   Max.   :7.1510

Let’s visualize consumption for one month.

ggplot(data_household_consumption[Date_Time >= as.Date("2023-04-01") & Date_Time <= as.Date("2023-05-01")]) +
  geom_line(aes(Date_Time, Load)) +
  labs(y = "Load (kW)") +
  theme_bw()

We can see that the behavior of the time series is very noisy but with clear daily pattern.

Let’s check more in detail, what we will face during forecasting, so I will show you the weekly average pattern (+/- standard deviation) by month.

data_household_consumption[, week_period := 1:.N, by = .(Week = lubridate::week(Date_Time))]
data_household_consumption[, month := lubridate::month(Date_Time, label = T)]
data_weekly_profiles <- copy(data_household_consumption[, .(Mean = mean(Load),
                                                            SD = sd(Load)),
                                                        by = .(month, week_period)])
 
ggplot(data_weekly_profiles, aes(x = week_period, Mean)) + 
  facet_wrap(~month) +
  geom_ribbon(data = data_weekly_profiles, aes(ymin = Mean - SD, ymax = Mean + SD),
              fill = "firebrick2", alpha = 0.4) +
  geom_line(linewidth = 0.9) + 
  geom_vline(xintercept = c(96, 96*4, 96*5, 96*6), linetype = 2, linewidth = 0.8) +
  theme(title = element_text(size = 14),
        axis.text = element_text(size = 10),
        axis.title = element_text(size = 12, face = "bold")) +
  labs(title = "Mean weekly profile +- deviation (SD)") +
  labs(x = "Time", y = "Load (kW)")

We can see that consumption patterns change over months…

I will show you also an average daily pattern by month.

data_household_consumption[, day_period := 1:.N, by = .(Date = date(Date_Time))]
data_daily_profiles <- copy(data_household_consumption[, .(Mean = mean(Load),
                                                            SD = sd(Load)),
                                                        by = .(month, day_period)])
 
ggplot(data_daily_profiles, aes(x = day_period, Mean)) + 
  facet_wrap(~month) +
  geom_ribbon(data = data_daily_profiles, aes(ymin = Mean - SD, ymax = Mean + SD),
              fill = "firebrick2", alpha = 0.4) +
  geom_line(linewidth = 0.9) + 
  theme(title = element_text(size = 14),
        axis.text = element_text(size = 10),
        axis.title = element_text(size = 12, face = "bold")) +
  labs(title = "Mean daily profile +- deviation (SD)") +
  labs(x = "Time", y = "Load (kW)")

It’s obvious that during winter months there is different behavior of electricity consumption, and much more consumed electricity because of heating needs.

smooth and ADAM

The main goal of this blog post is to try experimentally multistep losses in ETS model and compare them against classical losses (MSE and MAE).

In adam function we have several possibilities for multistep losses, check in here: https://openforecast.org/adam/multistepLosses.html.

I will use these in experiments:

MSEh, MAEh
TMSE – Trace MSE
GTMSE – Geometric Trace MSE
MSCE – Mean Squared Cumulative Error
GPL – General Predictive Likelihood

Let’s try adam on 4 weeks sample of data.

win_days <- 28 # 4 weeks
all_dates <- data_household_consumption[, unique(date(Date_Time))]
data_household_consumption_4weeks <- copy(data_household_consumption[Date_Time >= all_dates[1] & Date_Time < all_dates[win_days + 1]])

Firstly, I will try only the additive ETS model with classic MSE loss.

adam_model_classic <- adam(data = data_household_consumption_4weeks[, Load],
                           model = "XXX",
                           lags = c(1, 96, 96*7),
                           loss = "MSE",
                           h = 96,
                           holdout = T,
                           ic = "AICc",
                           initial = "back")
 
adam_model_classic

## Time elapsed: 0.99 seconds
## Model estimated using adam() function: ETS(ANA)[96, 672]
## Distribution assumed in the model: Normal
## Loss function type: MSE; Loss function value: 0.2732
## Persistence vector g:
##  alpha gamma1 gamma2 
## 0.5246 0.0000 0.0791 
## 
## Sample size: 2592
## Number of estimated parameters: 3
## Number of degrees of freedom: 2589
## Information criteria:
##      AIC     AICc      BIC     BICc 
## 3998.436 3998.445 4016.017 4016.053 
## 
## Forecast errors:
## ME: 0.041; MAE: 0.534; RMSE: 0.726
## sCE: 425.014%; Asymmetry: -15.5%; sMAE: 57.586%; sMSE: 61.353%
## MASE: 1.304; RMSSE: 1.2; rMAE: 0.845; rRMSE: 0.897

plot(adam_model_classic, which = 7)

We can see that ANA model is selected, so additive on level and season components, trend component was not used.

Let’s try multistep loss - GPL.

adam_model_multistep <- adam(data = data_household_consumption_4weeks[, Load],
                             model = "XXX",
                             lags = c(1, 96, 96*7),
                             loss = "GPL",
                             h = 96,
                             holdout = T,
                             ic = "AICc",
                             initial = "back")
 
adam_model_multistep

## Time elapsed: 25.37 seconds
## Model estimated using adam() function: ETS(ANA)[96, 672]
## Distribution assumed in the model: Normal
## Loss function type: GPL; Loss function value: -135.4807
## Persistence vector g:
##  alpha gamma1 gamma2 
## 0.0004 0.0000 0.0884 
## 
## Sample size: 2592
## Number of estimated parameters: 3
## Number of degrees of freedom: 2589
## Information criteria:
##      AIC     AICc      BIC     BICc 
## 3703.800 3703.809 3721.380 3721.417 
## 
## Forecast errors:
## ME: 0.075; MAE: 0.526; RMSE: 0.732
## sCE: 778.763%; Asymmetry: -7.8%; sMAE: 56.684%; sMSE: 62.332%
## MASE: 1.284; RMSSE: 1.21; rMAE: 0.832; rRMSE: 0.904

plot(adam_model_multistep, which = 7)

Also, ANA was selected. Better AICc and MAE with multistep loss, but RMSE was worse than in the MSE case. Let’s see on whole dataset…

Prediction simulations

I will roll predictions day by day with a whole 1-day prediction horizon with a train-set of length 28 days (win_days) on our household consumption data -> so 214 predictions will be made. I will use all multistep losses mentioned above, MAE, MSE, and STL+ARIMA, STL+ETS methods from the forecast package as benchmarks (as was used also in my previous blog post about bootstrapping). You can check R script how to simulate and compute this in parallel on my GitHub repository.

Now, let’s see generated predictions.

load("_rmd/data_household_predictions.Rdata")
data_predictions_all

##                   Date_Time Load_real Load_predicted    model
##      1: 2023-01-30 00:00:00     0.274     -0.7679345  STL+ETS
##      2: 2023-01-30 00:15:00     0.363     -0.7959601  STL+ETS
##      3: 2023-01-30 00:30:00     0.342     -0.7443988  STL+ETS
##      4: 2023-01-30 00:45:00     0.391     -0.8461708  STL+ETS
##      5: 2023-01-30 01:00:00     0.230     -0.8708582  STL+ETS
##     ---                                                      
## 205436: 2023-08-31 22:45:00     0.080      0.4030999 ADAM-GPL
## 205437: 2023-08-31 23:00:00     0.039      0.2060178 ADAM-GPL
## 205438: 2023-08-31 23:15:00     0.087      0.2489654 ADAM-GPL
## 205439: 2023-08-31 23:30:00     0.080      0.1719251 ADAM-GPL
## 205440: 2023-08-31 23:45:00     0.040      0.4710469 ADAM-GPL

I will compute forecasting evaluation metrics as RMSE, MAE, and MAAPE.

data_predictions_all[, .(RMSE = rmse(Load_real, Load_predicted),
                         MAE = mae(Load_real, Load_predicted),
                         MAAPE = maape(Load_real, Load_predicted)),
                     by = .(model)][order(MAE)]

##          model      RMSE       MAE    MAAPE
##  1:  ADAM-MSCE 0.7645952 0.5588521 77.19498
##  2:  ADAM-MAEh 0.7768230 0.5596729 75.60581
##  3:  ADAM-TMSE 0.7703792 0.5622345 77.03544
##  4:  ADAM-MSEh 0.7713433 0.5623389 76.99981
##  5: ADAM-GTMSE 0.7704186 0.5626845 77.15252
##  6:   ADAM-GPL 0.7704062 0.5629255 77.17820
##  7:   ADAM-MAE 0.8690460 0.6133876 78.18846
##  8:   ADAM-MSE 0.8701501 0.6152678 78.22642
##  9:  STL+ARIMA 0.8751174 0.6159549 78.60016
## 10:    STL+ETS 0.9403524 0.6500436 76.13823

We can see that all multistep losses are better than benchmark methods! That’s very nice results!

For further analysis, we will check only the two best multistep losses and two benchmarks.

models_sub <- c("ADAM-MSCE", "ADAM-MAEh", "ADAM-MAE", "STL+ARIMA")

Let’s see all generated prediction graphs with selected models:

ggplot(data_predictions_all[model %in% models_sub], aes(Date_Time, Load_predicted)) +
  facet_wrap(~model, ncol = 1) +
  geom_line(data = data_predictions_all[model %in% models_sub],
            aes(Date_Time, Load_real),
            color = "black") +
  geom_line(color = "firebrick1") +
  theme_bw()

There is a much lower variance of predictions with multistep losses ETS than in benchmarks, which’s interesting, but in nature of these losses logical also -> again check https://openforecast.org/adam/multistepLosses.html#multistepLosses.

Models diagnostics

Next, I will try to demonstrate how to compare results from multiple models and analyze them with model diagnostic methods, which are also described in adam forecasting book.

Let’s create residuals and abs(residuals) columns for investigation purposes.

data_predictions_all[, Error := Load_real - Load_predicted]
data_predictions_all[, AE := abs(Error)]

Let’s see the boxplot of absolute errors:

ggplot(data_predictions_all[model %in% models_sub],
       aes(model, AE, fill = model)) +
  geom_boxplot() +
  theme_bw()

We see narrower IQR with multistep losses, that’s a good feature.

Predictions vs real values scatter plot:

ggplot(data_predictions_all[model %in% models_sub],
       aes(Load_predicted, Load_real)) +
  facet_wrap(~model, scales = "fixed", ncol = 2) +
  geom_point(alpha = 0.5) +
  geom_abline(intercept = 0, slope = 1, color = "red", 
              linetype = "dashed", linewidth = 1) +
  geom_smooth(alpha = 0.4) +
  labs(title = "Predicted vs Real values") +
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

That is not very nice behavior in general, actually :), there are a lot of below-zero predictions (but fewer with multistep losses!) and no high-load predictions with multistep losses.

Residuals vs real values scatter plot:

ggplot(data_predictions_all[model %in% models_sub],
       aes(Error, Load_real)) +
  facet_wrap(~model, scales = "fixed") +
  geom_point(alpha = 0.5) +
  geom_smooth(alpha = 0.6) +
  xlab("resid (predicted_value - Load_real)") +
  labs(title = "Residual vs Real values") +
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

Again, it is not a very nice plot :) the conclusions are very similar to with previous one.

Heteroscedasticity check - so real values vs. absolute errors.

ggplot(data_predictions_all[model %in% models_sub],
       aes(Load_real, AE)) +
  facet_wrap(~model, scales = "fixed") +
  geom_point(alpha = 0.5) +
  geom_smooth(alpha = 0.6) +
  ylab("abs(resid)") +
  labs(title = "heteroscedasticity check") + 
  theme_bw()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

Our models have no heteroscedasticity at all, so absolute errors are not similarly distributed around real values distribution.

Let’s see assumptions of normally distributed errors - Q-Q plot check:

ggplot(data_predictions_all[model %in% models_sub],
       aes(sample = Error, group = model)) +
  facet_wrap(~model, scales = "fixed") +
  stat_qq() + stat_qq_line() +
  ylab("resid (predicted_value - Load_real)") +
  theme_bw()

We can see a nicer Q-Q plot with multistep losses - values are sliding on the optimal line much more than with benchmarks.

The last check is about the assumption that multistep forecasting errors have zero mean (will check it hourly - not by 15 minutes):

data_predictions_all[, Hour := lubridate::hour(Date_Time)]
 
ggplot(data_predictions_all[model %in% models_sub],
       aes(Hour, Error, group = Hour)) +
  facet_wrap(~model, scales = "free_y", ncol = 1) +
  geom_boxplot(alpha = 0.7, color = "black", fill = "gray") +
  geom_hline(yintercept = 0, color = "red") +
  geom_point(data = data_predictions_all[model %in% models_sub,
                                         .(Error = mean(Error)),
                                         by = .(model, Hour)],
             aes(Hour, Error, group = Hour), color = "firebrick2") +
  xlab("Hour (horizon)") +
  ylab("resid (predicted_value - Load_real)") +
  labs(title = "Multistep forecast errors have zero mean check") + 
  theme_bw()

All models are quite around zero, so good.

Summary

In this blog post, I showed that multistep losses in the ETS model have a great impact on forecast behavior:

lower variance,
and more accurate forecasts,

in our case of 1 day ahead household electricity consumption forecasting.

In general, household electricity consumption forecasting with ETS is not satisfactory as seen with model diagnostic methods that were showed -> higher values of consumption load are not well covered, etc.

In the future, I would like to show the possibility of improving forecasting accuracy with some ensemble methods, even with an ensemble of “weak” models such as ETS.

CoronaDash app use case - Clustering countries' COVID-19 active cases trajectories

Wed, 27 May 2020 00:00:00 +0000

COVID-19 disease spread hit the World really globally and also the field of mathematicians/ statisticians/ machine learning researchers and related. These experts want to help to understand for example future trends (forecast) of the coronavirus spread. My motivation, in this case, was to create interactive dashboard about COVID-19 to inform about various scenarios in every country and compare them through data mining methods.

I created CoronaDash shinydashboard application that is hosted on petolau.shinyapps.io RStudio platform. The dashboard provides various data mining/ visualization techniques for comparing countries’ COVID-19 data statistics as:

extrapolating total confirmed cases by exponential smoothing model,
trajectories of cases/ deaths spread,
multidimensional clustering of countries’ data/ statistics - with dendrogram and table of clusters averages,
aggregated views for the whole World,
hierarchical clustering of countries’ trajectories based on DTW distance and preprocessing by SMA (+ normalization), for fast comparison of a large number of countries’ COVID-19 magnitudes and trends.

The blog post will be about the last bullet of the above list - clustering of countries’ trajectories. This use case is challenging because of the clustering time series with different lengths.

CovidR contest

I submitted my shiny application also to the interesting initiative of eRum 2020 organizers - CovidR Contest.

Preprocessing COVID-19 open-data

Firstly, load all the needed packages for an analysis.

library(data.table) # data handling
library(TSrepr) # ts representations, use dev version devtools::install_github("PetoLau/TSrepr")
library(ggplot2) # visualisations
library(dtwclust) # clustering using DTW distance
library(dygraphs) # interactive visualizations
library(ggrepel) # nice labels in ggplot
library(dendextend) # dendrograms
library(DT) # nice datatable
library(htmlwidgets) # save html objects

I use data coming from Johns Hopkins CSSE GitHub repository - cases and deaths numbers, GitHub repository by ulklc - recovery cases number, tests data are coming from COVID19 API, and population sizes are from worldometers.

I prepared time series data at 2020-05-24 snapshot with various statistics also computed per 1 million population (so much better comparable), so let’s read them.

data_covid_ts <- fread("_rmd/data_covid_time_series_2020-05-24.csv")
data_covid_ts[, DateRep := as.Date(DateRep)] # transform character to Date class
 
# what we got
str(data_covid_ts)

## Classes 'data.table' and 'data.frame':	19344 obs. of  17 variables:
##  $ Country                                       : chr  "Afghanistan" "Afghanistan" "Afghanistan" "Afghanistan" ...
##  $ DateRep                                       : Date, format: "2020-01-22" "2020-01-23" "2020-01-24" "2020-01-25" ...
##  $ Cases_cumsum                                  : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Cases                                         : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Deaths_cumsum                                 : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Deaths                                        : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Recovered_cumsum                              : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Recovered                                     : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Active_cases_cumsum                           : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ New cases per 1 million population            : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ New deaths per 1 million population           : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ New recovered cases per 1 million population  : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Death rate (%)                                : num  NA NA NA NA NA NA NA NA NA NA ...
##  $ Total active cases per 1 million population   : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Total deaths per 1 million population         : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Total cases per 1 million population          : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ Total recovered cases per 1 million population: int  0 0 0 0 0 0 0 0 0 0 ...
##  - attr(*, ".internal.selfref")=<externalptr>

Since I want to analyze (cluster) trajectories of countries’ active cases spread, I need to set starting position for every countries’ time series - in this case (and in other many analyses out there) 100-th cumulative confirmed case is set as starting point. I will also use only top 82 affected countries (+ Slovakia as my home country) for the whole analysis. Let’s transform our data for ‘since first 100-th case’ countries’ trajectories (with the same lengths!).

n_cases <- 100 # you can vary
statistic <- 'Total active cases per 1 million population' # you can also choose other stat
 
# Cases greater than threshold
data_covid_100_cases <- copy(data_covid_ts[,
                                           .SD[DateRep >= .SD[Cases_cumsum >= n_cases,
                                                              min(DateRep,
                                                                  na.rm = T)]],
                                            by = .(Country)])
 
# Order data
setorder(data_covid_100_cases,
         Country,
         DateRep)
    
# Create 'days since' column
data_covid_100_cases[, (paste0("Days_since_first_",
                               n_cases, "_case")) := 1:.N,
                     by = .(Country)]
   
# top N countries selection for an analysis
data_cases_order <- copy(data_covid_100_cases[,
                                      .SD[DateRep == max(DateRep),
                                          get(statistic)],
                                      by = .(Country)
                                      ])
    
setnames(data_cases_order, "V1", statistic)
setorderv(data_cases_order, statistic, -1)
    
# subset data based on selected parameter -  top 82 countries and analyzed columns
data_covid_cases_sub <- copy(data_covid_100_cases[.(c(data_cases_order[1:82][!is.na(Country),
                                                                             Country],
                                                      "Slovakia")),
                                                  on = .(Country),
                                                 .SD,
                                                 .SDcols = c("Country",
                                                             paste0("Days_since_first_",
                                                                    n_cases, "_case"),
                                                             statistic)
                                                 ])
 
# Make same length time series from countries data
data_covid_trajectories <- dcast(data_covid_cases_sub,
                                 get(paste0("Days_since_first_", n_cases, "_case")) ~
                                   Country,
                                 value.var = statistic)
    
setnames(data_covid_trajectories,
         colnames(data_covid_trajectories)[1],
         paste0("Days_since_first_", n_cases, "_case"))
 
# see interactively what we got with DT package
dt <- DT::datatable(data_covid_trajectories,
                    class = "compact",
                    extensions = 'Scroller',
                    options = list(
                        dom = 't',
                deferRender = TRUE,
                    scrollY = 270,
                   scroller = TRUE,
                    scrollX = TRUE
                    ))
 
htmlwidgets::saveWidget(dt, "dt_traj_1.html", selfcontained = T)

You can see that we got nicely the same length time series for every country.

Now, preparation of trajectories’ data for clustering is coming… We have to remove missing rows/ columns if there are so + I will preprocess time series with Simple Moving Average (SMA) to little bit smooth our trajectories (removes noise) - the function repr_sma is implemented in my TSrepr package.

# save stats of dt
n_col <- ncol(data_covid_trajectories)
n_row <- nrow(data_covid_trajectories)
    
n_row_na <- rowSums(data_covid_trajectories[, lapply(.SD, is.na)])
n_col_na <- colSums(data_covid_trajectories[, lapply(.SD, is.na)])
    
# remove all NA rows and cols - for sure
if (length(which(n_row_na %in% n_col)) != 0) {
 
  data_covid_trajectories <- copy(data_covid_trajectories[-which(n_row_na == n_col)])
      
}
    
if (length(which(n_col_na %in% n_row)) != 0) {
      
  data_covid_trajectories <- copy(data_covid_trajectories[, -which(n_col_na %in% n_row),
                                                          with = FALSE])
      
}
 
# use SMA for preprocessing time series
q_sma <- 3 # order of moving average
 
data_covid_trajectories[,
                        (colnames(data_covid_trajectories)[-1]) :=
                          lapply(.SD, function(i)
                            c(rep(NA, q_sma - 1),
                              ceiling(repr_sma(i, q_sma))
                              )),
                        .SDcols = colnames(data_covid_trajectories)[-1]]
 
# again see data interactively
dt <- DT::datatable(data_covid_trajectories,
                    class = "compact",
                    extensions = 'Scroller',
                    options = list(
                        dom = 't',
                        deferRender = TRUE,
                        scrollY = 270,
                        scroller = TRUE,
                        scrollX = TRUE
                    ))
 
htmlwidgets::saveWidget(dt, "dt_traj_2.html", selfcontained = T)

Clustering trajectories with the hierarchical method with DTW distance

Since we use data with different lengths, we have to use different distance measures than Euclidean (or Manhattan, etc.). Here comes very handy Dynamic Time Warping distance measure that can compute distances between time series with various lags and different lengths.

As a clustering method, I picked hierarchical clustering with Ward criterion for its next nice post-analysis tools as dendrograms.

Let’s define clustering function with DTW distance with additional data preprocessing steps necessary for dtwclust package. I allow user also vary number of clusters and normalization of time series before clustering.

cluster_trajectories <- function(data, k, normalize = FALSE) {
  
  # transpose data for clustering
  data_trajectories_trans <- t(data[, .SD,
                                    .SDcols = colnames(data)[-1]])
  
  # create list of time series
  data_trajectories_trans_list <- lapply(1:nrow(data_trajectories_trans), function(i)
    na.omit(data_trajectories_trans[i,]))
  names(data_trajectories_trans_list) <- colnames(data)[-1]
 
  # remove data with length <= 1
  n_list <- sapply(1:length(data_trajectories_trans_list), function(i)
    length(data_trajectories_trans_list[[i]]))
  names(n_list) <- names(data_trajectories_trans_list)
 
  if (length(which(n_list %in% 0:1)) != 0) {
    
   data_trajectories_trans_list <- data_trajectories_trans_list[-which(n_list %in% 0:1)]
    
  }
  
  list_names <- names(data_trajectories_trans_list)
 
  # normalization
  if (normalize) {
    
    data_trajectories_trans_list <- lapply(names(data_trajectories_trans_list),
                                            function(i)
                                              norm_z(data_trajectories_trans_list[[i]])
                                                )
    names(data_trajectories_trans_list) <- list_names
    
  }
 
  # clustering with dtwclust package function
  hc_res <- tsclust(data_trajectories_trans_list,
                    type = "hierarchical",
                    k = k,
                    distance = "dtw_basic",
                    centroid = dba,
                    trace = FALSE,
                    seed = 54321,
                    control = hierarchical_control(method = "ward.D2"),
                    args = tsclust_args(dist = list(norm = "L2"))
                    )
  
  return(hc_res)
  
}

Let’s cluster data with 14 clusters and normalization of countries’ trajectories for extracting clusters with same trends (curves) - not magnitudes! It is very important thing before every clustering/ classification task.

clust_res <- cluster_trajectories(data = data_covid_trajectories,
                                  k = 14,
                                  normalize = TRUE)
 
# results
clust_res

## hierarchical clustering with 14 clusters
## Using dtw_basic distance
## Using dba centroids
## Using method ward.D2 
## 
## Time required for analysis:
##    user  system elapsed 
##    0.71    0.05    0.14 
## 
## Cluster sizes with average intra-cluster distance:
## 
##    size   av_dist
## 1    21 0.5011793
## 2     6 0.5170467
## 3     2 0.9447618
## 4    10 0.4015355
## 5    11 0.5774944
## 6     5 0.6441501
## 7     7 0.4719638
## 8     2 0.5682452
## 9     5 0.7722092
## 10    2 0.8360796
## 11    4 0.4361994
## 12    5 0.5527005
## 13    2 0.5363868
## 14    1 0.0000000

Let’s prepare clustered data for visualization:

# prepare time series
data_clust_id <- data.table(Cluster = clust_res@cluster,
                            Country = names(clust_res@cluster))
 
data_plot <- melt(data_covid_trajectories,
                  id.vars = colnames(data_covid_trajectories)[1],
                  variable.name = "Country",
                  variable.factor = FALSE,
                  value.name = statistic,
                  value.factor = FALSE)
 
data_plot <- copy(data_plot[.(data_clust_id$Country), on = .(Country)])
 
data_plot[data_clust_id,
          on = .(Country),
          Cluster := i.Cluster]
 
# again see what we got interactively
dt <- DT::datatable(data_plot,
              class = "compact",
              extensions = 'Scroller',
              filter = "top",
              options = list(
                dom = 't',
                deferRender = TRUE,
                scrollY = 270,
                scroller = TRUE,
                scrollX = TRUE
              ))
 
htmlwidgets::saveWidget(dt, "dt_data_plot.html", selfcontained = T)

You can also search for your preferred country in the datatable.

Here comes finally plot of cluster members with ggplot2 package (log scale is used for better comparison of trends):

theme_my <- theme(panel.border = element_rect(fill = NA,
                                                  colour = "grey10"),
                      panel.background = element_blank(),
                      panel.grid.minor = element_line(colour = "grey85"),
                      panel.grid.major = element_line(colour = "grey85"),
                      panel.grid.major.x = element_line(colour = "grey85"),
                      axis.text = element_text(size = 12, face = "bold"),
                      axis.title = element_text(size = 13, face = "bold"),
                      plot.title = element_text(size = 16, face = "bold"),
                      strip.text = element_text(size = 12, face = "bold"),
                      strip.background = element_rect(colour = "black"))
 
ggplot(data_plot,
       aes(get(colnames(data_plot)[1]),
           get(statistic),
           group = Country)) +
      facet_wrap(~Cluster,
                 ncol = ceiling(data_plot[, sqrt(uniqueN(Cluster))]),
                 scales = "free_y") +
      geom_line(color = "grey10",
                alpha = 0.75,
                size = 0.8) +
      scale_y_continuous(trans = 'log10') +
      labs(x = colnames(data_plot)[1],
           y = statistic) +
      theme_my

We can see nicely distinguishable clusters with various active cases trends (settled, rapid/ steady increase/ decrease).

Let’s check some clusters interactively with dygraphs package:

data_clust_focus <- dcast(data_plot[.(c(2,6)), on = .(Cluster)],
                          Days_since_first_100_case ~ Country,
                          value.var = statistic)
 
dyg <- dygraph(data_clust_focus,
        main = "Clusters n. 2 and 6") %>%
      dyAxis("x", label = colnames(data_clust_focus)[1]) %>%
      dyAxis("y", label = statistic) %>%
      dyOptions(strokeWidth = 2,
                drawPoints = F,
                pointSize = 3,
                pointShape = "circle",
                logscale = TRUE,
                colors = RColorBrewer::brewer.pal(ncol(data_clust_focus)-1, "Set2")) %>%
      dyHighlight(highlightSeriesOpts = list(strokeWidth = 2.5,
                                             pointSize = 4)) %>%
      dyLegend(width = 150, show = "follow",
               hideOnMouseOut = TRUE, labelsSeparateLines = TRUE)
 
saveWidget(dyg, "dyg_focus_clust_2_6.html", selfcontained = T)

Here, I picked two clusters (2 and 6) with nice decreasing trends - there are countries mostly from Central/ West Europe.

Let’s see also clusters with increasing trends of active cases per 1 mil. population:

data_clust_focus <- dcast(data_plot[.(7), on = .(Cluster)],
                          Days_since_first_100_case ~ Country,
                          value.var = statistic)
 
dyg <- dygraph(data_clust_focus,
               main = "Cluster n. 7") %>%
      dyAxis("x", label = colnames(data_clust_focus)[1]) %>%
      dyAxis("y", label = statistic) %>%
      dyOptions(strokeWidth = 2,
                drawPoints = F,
                pointSize = 3,
                pointShape = "circle",
                logscale = TRUE,
                colors = RColorBrewer::brewer.pal(ncol(data_clust_focus)-1, "Set2")) %>%
      dyHighlight(highlightSeriesOpts = list(strokeWidth = 2.5,
                                             pointSize = 4)) %>%
      dyLegend(width = 150, show = "follow",
               hideOnMouseOut = TRUE, labelsSeparateLines = TRUE)
 
saveWidget(dyg, "dyg_focus_clust_7.html", selfcontained = T)

data_clust_focus <- dcast(data_plot[.(1), on = .(Cluster)],
                          Days_since_first_100_case ~ Country,
                          value.var = statistic)
 
dyg <- dygraph(data_clust_focus,
               main = "Cluster n. 1") %>%
      dyAxis("x", label = colnames(data_clust_focus)[1]) %>%
      dyAxis("y", label = statistic) %>%
      dyOptions(strokeWidth = 2,
                drawPoints = F,
                pointSize = 3,
                pointShape = "circle",
                logscale = TRUE,
                colors = RColorBrewer::brewer.pal(ncol(data_clust_focus)-1, "Set2")) %>%
      dyHighlight(highlightSeriesOpts = list(strokeWidth = 2.5,
                                             pointSize = 4)) %>%
      dyLegend(width = 150, show = "follow",
               hideOnMouseOut = TRUE, labelsSeparateLines = TRUE)
 
saveWidget(dyg, "dyg_focus_clust_1.html", selfcontained = T)

We can see that on this day, the increasing trend of active cases has countries mostly in Western Asia, South America, and Africa.

Post-analysis visualizations with dendrograms and MDS

In order to see whole connectivity between countries’ clusters as a tree, we can use for example dendrogram. Here, we can simply use object of clustering result to generate the tree:

dend <- as.dendrogram(clust_res)
 
dend <- dend %>%
  color_branches(k = 14) %>%
  color_labels(k = 14) %>%
  set("branches_lwd", 1) %>%
  set("labels_cex", 0.8)
 
ggd1 <- as.ggdend(dend)
 
ggplot(ggd1,
       horiz = T)

In order to see for example connections between countries in 2D scatter plot, we can use dimensionality reduction method Multidimensional scaling (MDS). It uses (stored) distance matrix between objects - and we have it in our clustering result object (Yey clust_res@distmat!). For countries labels, I use great package ggrepel.

mds_classical <- cmdscale(clust_res@distmat, eig = FALSE, k = 2)
 
data_plot <- data.table(mds_classical,
                        Country = row.names(mds_classical),
                        Cluster = clust_res@cluster)
 
ggplot(data_plot, aes(x = get("V1"),
                      y = get("V2"),
                      label = Country,
                      color = as.factor(Cluster))) +
      geom_label_repel(size = 4.2,
                       alpha = 0.95,
                       segment.alpha = 0.35,
                       label.r = 0.1,
                       box.padding = 0.25,
                       label.padding = 0.3,
                       label.size = 0.35,
                       max.iter = 2500) +
      scale_color_manual(values = colorspace::rainbow_hcl(14, c = 90, l = 50)) +
      labs(x = NULL, y = NULL, color = NULL) +
      guides(color = FALSE) +
      theme_my

In both graphs (dendrogram and MDS scatter plot), we can see clearly how far (or close) are countries from each other based on DTW distance.

Summary

In this blog post, I showed you how to cluster time series with different lengths with DTW distance and hierarchical method, and how to visualize the results of such an analysis. As a use case, I picked data of countries’ COVID-19 active cases trajectories computed per 1 mil. population to see trends of the disease spread.

Sources

Application is running on petolau.shinyapps.io platform, the source code of the whole app is on CoronaDash GitHub repository.

Take care of yourself!

Dangerous streets of Bratislava! Animated maps using open data in R

Sun, 10 Nov 2019 00:00:00 +0000

At the work recently, I wanted to make some interesting start-up pitch (presentation) ready animated visualization and got some first experience with spatial data (e.g. polygons). I enjoyed working with such a type of data and I wanted to improve on working with them, so I decided to try to visualize something interesting with Bratislava (Slovakia) open-data and OpenStreetMaps. I ended with animated maps of violations on Bratislava streets through the time of 2 and a half years.

Since spatial time series are analyzed in this post, it still sticks with the blog domain and it is time series data mining :) You can read more about time series forecasting, representations and clustering in my previous blog posts here.

Aaand teaser, what I will create in this blog post:

In this blog post you will learn how to:

get free city district polygons data from OpenStreetMaps API,
get free street lines (polygons) coordinates from OpenStreetMaps API,
visualize polygons and street lines with ggplot2 and ggmap,
merge spatial data with violation data represented as time series,
animate spatial data combined with violation time series with gganimate.

Bratislava Open-Data

The ultimate goal is to show where and when are the most dangerous places in the capital of Slovakia - Bratislava. For this task, I will use open-data that cover violations gathered from the city police with locations (city district and street name) and time-stamp.

Firstly, load all the needed packages.

library(data.table) # handling data
library(lubridate) # handling timestamps
library(stringi) # text processing
library(osmdata) # OSM data API
# library(nominatim) # alternative OSM data API
library(sf) # handling spatial data
library(ggplot2) # visualisations
library(ggsci) # color pallets
library(ggmap) # map vis
library(gganimate) # animations
library(magick) # image handling

Then, let’s download the violations data from opendata.bratislava.sk webpage and translate Slovak column names to English.

data_violation_17 <- fread("https://opendata.bratislava.sk/dataset/download/pocet-priestupkov-podla-druhu-udalosti-v-roku-r/1",
                           encoding = "Latin-1")
data_violation_18 <- fread("https://opendata.bratislava.sk/dataset/download/pocet-priestupkov-podla-druhu-udalosti-v-roku-/1",
                           encoding = "Latin-1")
data_violation_19 <- fread("https://opendata.bratislava.sk/dataset/download/pocet-priestupkov-podla-druhu-udalosti-----ethyanzgrthar/1",
                           encoding = "Latin-1")
 
# colnames to English
setnames(data_violation_17, colnames(data_violation_17), c("Date_Time", "Group_vio",
                                                           "Type_vio", "Street", "Place"))
setnames(data_violation_18, colnames(data_violation_18), c("Date_Time", "Group_vio",
                                                           "Type_vio", "Street", "Place"))
setnames(data_violation_19, colnames(data_violation_19), c("Date_Time", "Group_vio",
                                                           "Type_vio", "Street", "Place"))

Let’s bind all the data together.

data_violation <- rbindlist(list(data_violation_17, data_violation_18, data_violation_19),
                            use.names = T)

Next, I will transform Date_Time to POCIXct format and generate time aggregation features - Year and Month - Year_M.

data_violation[, Date_Time := dmy_hm(Date_Time)]
data_violation[, Date := date(Date_Time)]
 
# Aggregation features
data_violation[, Month := month(Date_Time)]
data_violation[, Year := year(Date_Time)]
data_violation[, Year_M := Year + Month/100]

Let’s see how many violations have each Place (city district) for whole available period (2017-2019.09):

data_violation[, .N, by = .(Place)]

##                 Place     N
##  1:       Stare Mesto 68714
##  2:       Karlova Ves 11462
##  3:         Petrzalka 17062
##  4:          Dubravka  6307
##  5:           Ruzinov 21352
##  6:           Vajnory  1194
##  7:    Pod. Biskupice  1590
##  8:           Vrakuna  1262
##  9:        Nove Mesto 17964
## 10:             Devin   269
## 11:              Raca  2390
## 12: Devinska Nova Ves  1406
## 13:             Lamac  1455
## 14:           Jarovce    66
## 15:     Zah. Bystrica   928
## 16:           Rusovce   753
## 17:            Cunovo   569

We can see that Old-town (Stare Mesto) rocks in this statistic..obviously - e.g. lot of tourists. There are also some misunderstand Slavic letters. We should get rid of them - in the blog post there we be lot of handling of these special Slavic (Slovak) symbols.

data_violation[, Place := stri_trans_general(Place, "Latin-ASCII")]
data_violation[.("Eunovo"), on = .(Place), Place := "Cunovo"]
data_violation[.("Raea"), on = .(Place), Place := "Raca"]
data_violation[.("Vrakuoa"), on = .(Place), Place := "Vrakuna"]
data_violation[.("Lamae"), on = .(Place), Place := "Lamac"]

I will extract only types of violations that relate to the bad behavior of people, like harassment, using alcoholic beverages on public space and related things. So, I will not extract traffic violations like bad car parking, etc. For this task, I need to extract codes of violations:

data_violation[, Group_vio_ID := as.numeric(substr(Group_vio, 1, 4))]
# our codes are: 4836, 5000, 4834, 4700, 4838, 4828, 4839,
# 4813, 9803, 4840, 4841, 9809, 3000, 9806, 4900

Polygons of city districts

I want to show a number of crimes per city district and street (so both place information) on a map, so I need to get coordinates of city districts and streets. Let’s get polygons of city districts first using OpenStreetMap API.

poly_sm <- getbb(place_name = "Stare Mesto Bratislava", format_out = "polygon")
poly_nm <- getbb(place_name = "Nove Mesto Bratislava", format_out = "polygon")
poly_ruz <- getbb(place_name = "Ruzinov Bratislava", format_out = "polygon")
poly_raca <- getbb(place_name = "Raca Bratislava", format_out = "polygon")
poly_petr <- getbb(place_name = "Petrzalka Bratislava", format_out = "polygon")
poly_kv <- getbb(place_name = "Karlova Ves Bratislava", format_out = "polygon")
poly_dubr <- getbb(place_name = "Dubravka Bratislava", format_out = "polygon")
poly_vajn <- getbb(place_name = "Vajnory Bratislava", format_out = "polygon")
poly_lamac <- getbb(place_name = "Lamac Bratislava", format_out = "polygon")
poly_vrak <- getbb(place_name = "Vrakuna Bratislava", format_out = "polygon")
poly_pd <- getbb(place_name = "Podunajske Biskupice Bratislava", format_out = "polygon")
poly_jar <- getbb(place_name = "Jarovce Bratislava", format_out = "polygon")
poly_dnv <- getbb(place_name = "Devinska Nova Ves Bratislava", format_out = "polygon")
poly_rus <- getbb(place_name = "Rusovce Bratislava", format_out = "polygon")
poly_zb <- getbb(place_name = "Zahorska Bystrica Bratislava", format_out = "polygon")
poly_devin <- getbb(place_name = "Devin Bratislava", format_out = "polygon")
poly_cun <- getbb(place_name = "Cunovo Bratislava", format_out = "polygon")

Let’s bind all the districts data of Bratislava.

data_poly_ba <- rbindlist(list(
  as.data.table(poly_sm)[, Place := "Stare Mesto"],
  as.data.table(poly_nm[[1]])[, Place := "Nove Mesto"],
  as.data.table(poly_ruz[[1]])[, Place := "Ruzinov"],
  as.data.table(poly_raca)[, Place := "Raca"],
  as.data.table(poly_petr)[, Place := "Petrzalka"],
  as.data.table(poly_kv[[1]])[, Place := "Karlova Ves"],
  as.data.table(poly_dubr[[1]])[, Place := "Dubravka"],
  as.data.table(poly_vajn[[1]])[, Place := "Vajnory"],
  as.data.table(poly_lamac[[1]])[, Place := "Lamac"],
  as.data.table(poly_vrak[[1]])[, Place := "Vrakuna"],
  as.data.table(poly_pd[[1]])[, Place := "Pod. Biskupice"],
  as.data.table(poly_jar[[1]])[, Place := "Jarovce"],
  as.data.table(poly_dnv[[1]])[, Place := "Devinska Nova Ves"],
  as.data.table(poly_rus[[1]])[, Place := "Rusovce"],
  as.data.table(poly_zb[[1]])[, Place := "Zah. Bystrica"],
  as.data.table(poly_devin[[1]])[, Place := "Devin"],
  as.data.table(poly_cun[[1]])[, Place := "Cunovo"]
))
 
setnames(data_poly_ba, c("V1", "V2"), c("lon", "lat"))
data_poly_ba[, Place := factor(Place)]

Let’s visualize simply the districts.

ggplot(data_poly_ba) +
  geom_polygon(aes(x = lon, y = lat,
                   fill = Place, color = Place)) +
  
  theme_void()

For animation and visualization purposes, I need to aggregate violations data by districts (Place) and Year+Month columns (Year_M).

data_violation_agg_place <- copy(data_violation[.(c(4836, 5000, 4834, 4700, 4838,
                                                    4828, 4839, 4813, 9803, 4840,
                                                    4841, 9809, 3000, 9806, 4900)),
                                                on = .(Group_vio_ID),
                                                .(N = .N),
                                                by = .(Place, Year_M)])

The next step is to merge polygon data with aggregated violation data:

data_places <- merge(data_poly_ba[, .(Place, lon, lat)],
                     data_violation_agg_place[, .(Place, N_violation = N, Year_M)],
                     by = "Place",
                     all.y = T,
                     allow.cartesian = T)

Let’s also compute mean coordinates for every district for showing theirs names on a graph.

data_poly_ba_mean_place <- copy(data_poly_ba[, .(lon = mean(lon),
                                                 lat = mean(lat)),
                                             by = .(Place)])

Let’s test visualization of violations on June 2019:

ggplot() +
  geom_polygon(data = data_places[.(2019.06), on = .(Year_M)],
               aes(x = lon, y = lat,
                   fill = N_violation,
                   group = Place),
               color = "grey40") +
  scale_fill_material("grey") +
  geom_label(data = data_poly_ba_mean_place,
             aes(x = lon, y = lat, label = Place),
             color = "black", fill = "dodgerblue1", alpha = 0.65) +
  theme_void()

Street lines coordinates

The next step is to download street coordinates from OpenStreetMaps.

Firstly, we have to extract unique street names from violation data, and handle Slovak letters and other punctuation for easier matching by street name.

dt_uni_streets <- copy(data_violation[, .(Place = data.table::first(Place)),
                                      by = .(Street)])
 
dt_uni_streets[, Street_edit := gsub(pattern = "Ãˆ", replacement = "C", x = Street)]
dt_uni_streets[, Street_edit := gsub(pattern = "Ã²", replacement = "n", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Ã¨", replacement = "c", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "\u009d", replacement = "t", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Â¾", replacement = "l", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Â¼", replacement = "L", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Ã²", replacement = "n", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "_", replacement = "", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Ã¯", replacement = "d", x = Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Ã ", replacement = "r", x = Street_edit)]
dt_uni_streets[, Street_edit := stri_trans_general(Street_edit, "Latin-ASCII")]
dt_uni_streets[, Street_edit := sub(" - MC.*", "", Street_edit)]
dt_uni_streets[, Street_edit := gsub(pattern = "Nam.", replacement = "Namestie ",
                                     x = Street_edit)]
 
dt_uni_streets[, Street_query := gsub(pattern = " ", replacement = "+", x = Street_edit)]
dt_uni_streets[, Street_query := paste0(Street_query, "+Bratislava")]

Let’s get all streets coordinates of Bratislava just by one (powerful) command, again using OSM API:

ba_bb <- getbb(place_name = "Bratislava")
 
bratislava <- opq(bbox = ba_bb) %>%
  add_osm_feature(key = 'highway') %>%
  osmdata_sf() %>%
  osm_poly2line()

Let’s plot it:

ggplot(data = bratislava$osm_lines) +
  geom_sf() +
  theme_bw()

Pretty nice web.

Now, we need to handle again street names downloaded from OSM. I will extract only available streets from violation data:

street_names <- data.table(Street = unique(bratislava$osm_lines$name))
 
street_names[, Street_edit := gsub(pattern = "Ãƒ", replacement = "i", x = Street)]
street_names[, Street_edit := gsub(pattern = "iÂ©", replacement = "e", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂ¡", replacement = "a", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂº", replacement = "u", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…Â¾", replacement = "z", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„Â¾", replacement = "l", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„\u008d", replacement = "c", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…Â¡", replacement = "s", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„Â½", replacement = "L", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…Ë†", replacement = "n", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂ½", replacement = "y", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…â€¢", replacement = "r", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂ³", replacement = "o", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂ¤", replacement = "a", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…Â½", replacement = "Z", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã… ", replacement = "S", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…Â¥", replacement = "t", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„Å’", replacement = "C", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„\u008f", replacement = "d", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "iÂ¶", replacement = "o", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã…â€˜", replacement = "o", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„â€º", replacement = "e", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "Ã„â€º", replacement = "e", x = Street_edit)]
 
street_names[, Street_edit := stri_trans_general(Street_edit, "Latin-ASCII")]
street_names[, Street_edit := gsub(pattern = "i-", replacement = "i", x = Street_edit)]
street_names[, Street_edit := gsub(pattern = "A ", replacement = "S", x = Street_edit)]
 
street_names[dt_uni_streets, on = .(Street_edit)]
street_names_vio <- copy(street_names[dt_uni_streets, on = .(Street_edit),
                                      Street_orig := i.Street])[!is.na(Street_orig)]

We lost some street data from the dataset by not exact matched street names.

Let’s subset the street data.

ba_streets_vio <- bratislava$osm_lines
ba_streets_vio <- ba_streets_vio[ba_streets_vio$name %in% street_names_vio$Street,]
ba_streets_vio <- ba_streets_vio[!is.na(ba_streets_vio$name),]

Now, I will transform data to standard lon/lat matrix (data.table class) format instead of sf object (I highly recommend this for next ggplot usage).

data_streets_st <- data.table::data.table(sf::st_coordinates(ba_streets_vio$geometry))

Next, I will bound streets by existing polygons of Bratislava and add merging column - Street_edit:

ba_streets_vio$L1 <- 1:nrow(ba_streets_vio)
data_streets_st <- merge(data_streets_st, as.data.table(ba_streets_vio)[, .(L1, name)],
                         by = "L1")
data_streets_st[street_names_vio[, .(name, Street_edit)], on = .(name),
                Street_edit := i.Street_edit]
setnames(data_streets_st, c("X", "Y"), c("lon", "lat"))
data_streets_st <- data_streets_st[!lon > data_poly_ba[, max(lon)]]
data_streets_st <- data_streets_st[!lon < data_poly_ba[, min(lon)]]
data_streets_st <- data_streets_st[!lat > data_poly_ba[, max(lat)]]

Let’s also aggregate violation data by street names and Year + Month (Year_M):

data_violation_agg_street <- copy(data_violation[.(c(4836, 5000, 4834, 4700, 4838,
                                                    4828, 4839, 4813, 9803, 4840,
                                                    4841, 9809, 3000, 9806, 4900)),
                                                 on = .(Group_vio_ID),
                                                 .(N = .N), by = .(Street, Year_M)])
 
setorder(data_violation_agg_street, Year_M, -N)

Let’s add look-up column Street_edit to aggregated data and merge spatial street data with violation data.

data_violation_agg_street[dt_uni_streets, on = .(Street), Street_edit := i.Street_edit]
 
data_streets_st <- merge(data_streets_st,
                         data_violation_agg_street[, .(Street_edit, N_violations = N, Year_M)],
                         by = "Street_edit",
                         all.y = T,
                         allow.cartesian = TRUE)

Now, I will transform integers of the number of violations to reasonable factors segments:

data_streets_st[N_violations >= 11, N_violation_type := "> 11"]
data_streets_st[N_violations >= 6 & N_violations < 11, N_violation_type := "(6, 10)"]
data_streets_st[N_violations >= 3 & N_violations < 6, N_violation_type := "(3, 5)"]
data_streets_st[N_violations <= 2, N_violation_type := "< 2"]
data_streets_st[, N_violations_per_street := factor(N_violation_type,
                                                    levels = c("< 2",  "(3, 5)",
                                                               "(6, 10)", "> 11"))]

levels(data_streets_st$N_violations_per_street)

## [1] "< 2"     "(3, 5)"  "(6, 10)" "> 11"

Let’s see what we extracted so far for streets in one example year-month…

ggplot(data_streets_st[!is.na(L1)][.(2019.06),
                                   on = .(Year_M)]) +
  geom_line(aes(lon, lat, group = L1,
                color = N_violations_per_street),
            size = 1.4) +
  scale_color_brewer(palette = "Reds") +
  theme_bw()

ggmap

Since, we will use ggmap for visualizations, we need to extract map image of Bratislava:

bbox <- make_bbox(lon, lat, data = data_poly_ba, f = .01) # used our polygons
map_ba <- get_map(location = bbox, source = 'stamen', maptype = "watercolor")

Now, let’s make it altogether to one visualization - so violations by city districts and also streets for one time-stamp (Year_M).

ggmap(map_ba, extent = "device") +
  geom_polygon(data = data_places[.(2019.06),
                                  on = .(Year_M)],
               aes(x = lon, y = lat,
                   fill = N_violation,
                   group = Place),
               color = "grey40") +
  scale_fill_material("grey", alpha = 0.75) +
  geom_line(data = data_streets_st[!is.na(L1)][.(2019.06),
                                               on = .(Year_M)],
            aes(lon, lat, group = L1, color = N_violations_per_street),
            size = 1.4) +
  scale_color_brewer(palette = "Reds") +
  geom_label(data = data_poly_ba_mean_place,
             aes(x = lon, y = lat, label = Place,
                 fill = NA_real_),
             color = "black", fill = "dodgerblue1", alpha = 0.75) +
  labs(fill = "N_vio_district", color = "N_vio_street") +
  guides(color = guide_legend(override.aes = list(size = 2))) +
  theme_void()

I will also extract the most violated streets by Year+Month for labeling purposes.

data_streets_st_max <- copy(data_streets_st[!is.na(L1),
                                            .SD[N_violations == max(N_violations, na.rm = T)],
                                            by = .(Year_M)])
 
data_streets_st_max[, unique(Street_edit)] # the unique month "winners"
data_streets_st_max <- copy(data_streets_st_max[, .(lon = mean(lon),
                                                    lat = mean(lat),
                                                    Street_edit = first(Street_edit),
                                                    N_violations = first(N_violations),
                                                    N_violations_per_street = 
                                                      first(N_violations_per_street)
                                                    ),
                                                by = .(Year_M)])

As we noticed so far, the most violated city district is Old-town, so I will create also zoomed visualization for this city district like this (using coord_map function):

ggmap(map_ba) +
  geom_polygon(data = data_places[.(2019.06), on = .(Year_M)],
               aes(x = lon, y = lat,
                   fill = N_violation,
                   group = Place
               ),
               color = "grey40") +
  scale_fill_material("grey", alpha = 0.75) +
  geom_line(data = data_streets_st[!is.na(L1)][.(2019.06), on = .(Year_M)],
            aes(lon, lat, group = L1, color = N_violations_per_street),
            size = 1.4) +
  geom_label(data = data_streets_st_max[.(2019.06), on = .(Year_M)],
             aes(x = lon, y = lat,
                 label = paste0(Street_edit, " - ", N_violations)
             ),
             color = "black",
             fill = "firebrick2",
             size = 4.5,
             alpha = 0.75
  ) +
  scale_color_brewer(palette = "Reds") +
  geom_label(data = data_poly_ba_mean_place,
             aes(x = lon, y = lat, label = Place,
                 fill = NA_real_),
             color = "black", fill = "dodgerblue1",
             alpha = 0.75, size = 4.5) +
  coord_map(
    xlim=c(data_poly_ba[.("Stare Mesto"), on = .(Place), min(lon)],
           data_poly_ba[.("Stare Mesto"), on = .(Place), max(lon)]),
    ylim= c(data_poly_ba[.("Stare Mesto"), on = .(Place), min(lat)],
            data_poly_ba[.("Stare Mesto"), on = .(Place), max(lat)])
  ) +
  labs(fill = "N_vio_district", color = "N_vio_street") +
  guides(color = guide_legend(ncol = 1, override.aes = list(size = 2),
                              title.position = "top"),
         fill = guide_legend(nrow = 2, title.position = "top")) +
  theme_bw() +
  theme(axis.text = element_blank(),
        axis.line = element_blank(),
        axis.title = element_blank(),
        axis.ticks = element_blank(),
        legend.text = element_text(size = 13),
        legend.title = element_text(size = 14, face = "bold"),
        legend.background = element_rect(fill = "white"),
        legend.key = element_rect(fill = "white"),
        legend.position = "bottom")

Using ggnanimate

We have all prepared to create some interesting animated map. For this purpose, I will use the gganimate package that simply uses the transition_states function that combines our previously prepared ggplot2 and ggmap plot and time feature Year_M. Let’s firstly animate the whole city picture.

gg_ba_anim_lines <- ggmap(map_ba, extent = "device") +
  geom_polygon(data = data_places,
               aes(x = lon, y = lat,
                   fill = N_violation,
                   group = Place),
               color = "grey40") +
  scale_fill_material("grey", alpha = 0.7) +
  geom_line(data = data_streets_st[!is.na(L1)],
            aes(lon, lat,
                group = L1,
                color = N_violations_per_street
            ),
            size = 1.4
  ) +
  scale_color_brewer(palette = "Reds") +
  labs(fill = "N_vio_district", color = "N_vio_street") +
  geom_label(data = data_poly_ba_mean_place,
             aes(x = lon, y = lat, label = Place,
                 fill = NA_real_),
             color = "black", fill = "dodgerblue1",
             alpha = 0.75, size = 4.5) +
  transition_states(reorder(Year_M, Year_M), transition_length = 2,
                    state_length = 1) +
  labs(title = "Year.Month - {closest_state}") +
  guides(color = FALSE, fill = FALSE) +
  theme_void() +
  theme(plot.title = element_text(size = 16, face = "bold")
  )
 
# save animation to object
anim_whole <- animate(gg_ba_anim_lines, duration = 46, width = 700, height = 750)

Then, let’s animate zoomed map of Old-town district.

gg_ba_anim_lines_zoom <- ggmap(map_ba, extent = "device") +
  geom_polygon(data = data_places,
               aes(x = lon, y = lat,
                   fill = N_violation,
                   group = Place),
               color = "grey40") +
  scale_fill_material("grey", alpha = 0.7) +
  geom_line(data = data_streets_st[!is.na(L1)],
            aes(lon, lat,
                group = L1,
                color = N_violations_per_street
            ),
            size = 1.4
  ) +
  scale_color_brewer(palette = "Reds") +
  geom_label(data = data_streets_st_max,
             aes(x = lon, y = lat,
                 label = paste0(Street_edit, " - ", N_violations)
             ),
             color = "black", fill = "firebrick2",
             alpha = 0.75, size = 4.5
  ) +
  geom_label(data = data_poly_ba_mean_place,
             aes(x = lon, y = lat, label = Place,
                 fill = NA_real_),
             color = "black", fill = "dodgerblue1",
             alpha = 0.75, size = 4.5
  ) +
  coord_map(
    xlim=c(data_poly_ba[.("Stare Mesto"), on = .(Place), min(lon)],
           data_poly_ba[.("Stare Mesto"), on = .(Place), max(lon)]),
    ylim= c(data_poly_ba[.("Stare Mesto"), on = .(Place), min(lat)],
            data_poly_ba[.("Stare Mesto"), on = .(Place), max(lat)])
  ) +
  transition_states(reorder(Year_M, Year_M), transition_length = 2,
                    state_length = 1) +
  labs(fill = "N_vio_district", color = "N_vio_street") +
  guides(color = guide_legend(ncol = 1, override.aes = list(size = 2),
                              title.position = "top"),
         fill = guide_legend(nrow = 2, title.position = "top")) +
  theme_bw() +
  theme(axis.text = element_blank(),
        axis.line = element_blank(),
        axis.title = element_blank(),
        axis.ticks = element_blank(),
        legend.text = element_text(size = 13),
        legend.title = element_text(size = 14, face = "bold"),
        legend.background = element_rect(fill = "white"),
        legend.key = element_rect(fill = "white"),
        legend.position = "bottom")
 
# save animation to object
anim_zoom <- animate(gg_ba_anim_lines_zoom, duration = 46, width = 700, height = 750)

GIFS binding with magick package

Now, we have to bind these two animations into one GIF. I will do it by functions from the magick package.

a_mgif <- image_read(anim_whole)
b_mgif <- image_read(anim_zoom)
 
new_gif <- image_append(c(a_mgif[1],
                          b_mgif[1]))
 
for(i in 2:100){
  combined <- image_append(c(a_mgif[i],
                             b_mgif[i]))
  new_gif <- c(new_gif, combined)
}
 
# final!
new_gif

Voilaaa:

For full resolution - right click on the gif and click on the view image option.

We can see that at the end of the observed period, so the summer of 2019, the Old-town district has even-more violations than usual. That can be caused by multiple factors…

Also notice, that peripheral areas of districts as Ruzinov and Vrakuna have streets with repeating multiple violations.

Streets with the most violations

Let’s see some of the most violated streets as time series as we seen in the animation.

times <- data.table(Year_M = data_violation_agg_street[, sort(unique(Year_M))])
times[, Date := as.Date("2017-01-01")]
times[, row_id := 1:.N]
times[, Date := Date + row_id*30.4]
 
data_vio_most_street <- copy(data_violation_agg_street[
  .(c("Michalska", "Postova",
      "Rybarska brana", "Namestie slobody")),
  on = .(Street_edit)])
 
data_vio_most_street[times, on = .(Year_M), Date := i.Date]
setnames(data_vio_most_street, "N", "N_violations")
 
ggplot(data_vio_most_street) +
  geom_line(aes(Date, N_violations, color = Street_edit), size = 0.8) +
  theme_bw()

The most of the time, Michalska street in the historical center of the Old-town was the most violated street, but the last three months is Postova the “winner of the most violated street”…this is maybe because of the new city-police station nearby.

Summary

In this blog post, I showed you how to:

work with different spatial data as polygons, street lines or map images,
combine these spatial objects with external data as city violation time series,
create animated maps using packages as ggplot2, ggmap, gganimate, and magick.

I hope, you will use these information with your spatial-time series data combo for creating some interesting visualization :)

The source code for this blog post can be found on my GitHub repository.

Bootstrapping time series for improving forecasting accuracy

Mon, 21 Oct 2019 00:00:00 +0000

Bootstrapping time series? It is meant in a way that we generate multiple new training data for statistical forecasting methods like ARIMA or triple exponential smoothing (Holt-Winters method etc.) to improve forecasting accuracy. It is called bootstrapping, and after applying the forecasting method on each new time series, forecasts are then aggregated by average or median - then it is bagging - bootstrap aggregating. It is proofed by multiple methods, e.g. in regression, that bagging helps improve predictive accuracy - in methods like classical bagging, random forests, gradient boosting methods and so on. The bagging methods for time series forecasting were used also in the latest M4 forecasting competition. For residential electricity consumption (load) time series (as used in my previous blog posts), I proposed three new bootstrapping methods for time series forecasting methods. The first one is an enhancement of the originally proposed method by Bergmeir - link to article - and two clustering-based methods. I also combined classical bagging for regression trees and time series bagging to create ensemble forecasts - I will cover it in some next post. These methods are all covered in the journal article entitled: Density-based Unsupervised Ensemble Learning Methods for Time Series Forecasting of Aggregated or Clustered Electricity Consumption.

In this blog post, I will cover:

an introduction to the bootstrapping of time series,
new bootstrapping methods will be introduced,
extensive experiments with 7 forecasting methods and 4 bootstrapping methods will be described and analysed on a part of M4 competition dataset.

Bootstrapping time series data

Firstly, read the M4 competition data, which compromise 100 thousand time series and load all the needed packages.

library(M4comp2018) # M4 data,
# install package by devtools::install_github("carlanetto/M4comp2018")
library(data.table) # manipulating the data
library(TSrepr) # forecasting error measures
library(forecast) # forecasting and bootstrapping methods
library(ggplot2) # graphics
library(ggsci) # colours
library(clusterCrit) # int.validity indices
 
data(M4)

I will use only time series with hourly frequency (so with the highest frequency from M4 dataset, and they can have daily and also weekly seasonality), because I use at work also time series with double-seasonality (quarter-hourly or half-hourly data). The high (or double) period (frequency) also means higher complexity and challenge, therefore it is great for this use case :)

hourly_M4 <- Filter(function(l) l$period == "Hourly", M4)

Let’s plot random time series from the dataset:

theme_ts <- theme(panel.border = element_rect(fill = NA, 
                                              colour = "grey10"),
                  panel.background = element_blank(),
                  panel.grid.minor = element_line(colour = "grey85"),
                  panel.grid.major = element_line(colour = "grey85"),
                  panel.grid.major.x = element_line(colour = "grey85"),
                  axis.text = element_text(size = 13, face = "bold"),
                  axis.title = element_text(size = 15, face = "bold"),
                  plot.title = element_text(size = 16, face = "bold"),
                  strip.text = element_text(size = 16, face = "bold"),
                  strip.background = element_rect(colour = "black"),
                  legend.text = element_text(size = 15),
                  legend.title = element_text(size = 16, face = "bold"),
                  legend.background = element_rect(fill = "white"),
                  legend.key = element_rect(fill = "white"),
                  legend.position="bottom")
 
ggplot(data.table(Time = 1:length(hourly_M4[[1]]$x),
                  Value = as.numeric(hourly_M4[[1]]$x))) +
  geom_line(aes(Time, Value)) +
  labs(title = hourly_M4[[1]]$st) +
  theme_ts

Bootstrap aggregating (bagging) is an ensemble meta-algorithm (introduced by Breiman in 1996), which creates multiple versions of learning set to produce multiple numbers of predictions. These predictions are then aggregated, for example by arithmetic mean. For time dependent data with a combination of statistical forecasting methods, the classical bagging can’t be used - so sampling (bootstrapping) with replacement. We have to sample data more sophisticated - based on seasonality or something similar. One of the used bootstrapping method is Moving Block Bootstrap (MBB) that uses a block (defined by seasonality for example) for creating new series. However, we don’t use the whole time series as it is, but we bootstrap only its remainder part from STL decomposition (this bootstrapping method was proposed by Bergmeir et al. in 2016).

This method is implemented in the forecast package in bld.mbb.bootstrap function, let’s use it on one time series from M4 competition dataset:

period <- 24*7 # weekly period
data_ts <- as.numeric(hourly_M4[[1]]$x)
data_boot_mbb <- bld.mbb.bootstrap(ts(data_ts, freq = period), 100)
data_plot <- data.table(Value = unlist(data_boot_mbb),
                        ID = rep(1:length(data_boot_mbb), each = length(data_ts)),
                        Time = rep(1:length(data_ts), length(data_boot_mbb))
                        )
 
ggplot(data_plot) +
  geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
  geom_line(data = data_plot[.(1), on = .(ID)], aes(Time, Value),
            color = "firebrick1", alpha = 0.9, size = 0.8) +
  theme_ts

We can see that where values of the time series are low, there bld.mbb method fails to bootstrap new values around original ones (red line). Notice also that variance of bootstrapped time series is very high and values fly somewhere more than 30% against original values.

For this reason, I proposed a smoothed version of the bld.mbb method for reducing variance (Laurinec et al. 2019). I smoothed the remainder part from STL decomposition by exponential smoothing, so extreme noise was removed. Let’s use it (source code is available on my GitHub repo):

data_boot_smbb <- smo.bootstrap(ts(data_ts, freq = period), 100)
data_plot <- data.table(Value = unlist(data_boot_smbb),
                        ID = rep(1:length(data_boot_smbb), each = length(data_ts)),
                        Time = rep(1:length(data_ts), length(data_boot_smbb))
                        )
 
ggplot(data_plot) +
  geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
  geom_line(data = data_plot[.(1), on = .(ID)], aes(Time, Value),
            color = "firebrick1", alpha = 0.9, size = 0.8) +
  theme_ts

We can see that the variance was nicely lowered, but the final time series are sometimes really different from the original. It is not good when we want to use them for forecasting.

Therefore, I developed (designed) another two bootstrapping methods based on K-means clustering. The first step of the two methods is identical - automatic clustering of univariate time series - where automatic means that it estimates the number of clusters from a defined range of clusters by Davies-Bouldin index.

The first method, after clustering, samples new values from cluster members, so it isn’t creating new values. Let’s plot results:

data_boot_km <- KMboot(ts(data_ts, freq = period), 100, k_range = c(8, 10))
data_plot <- data.table(Value = unlist(data_boot_km),
                        ID = rep(1:length(data_boot_km), each = length(data_ts)),
                        Time = rep(1:length(data_ts), length(data_boot_km))
                       )
 
ggplot(data_plot) +
  geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
  geom_line(data = data_plot[.(1), on = .(ID)], aes(Time, Value),
            color = "firebrick1", alpha = 0.9, size = 0.8) +
  theme_ts

We can change the range of the number of clusters to be selected to lower to increase the variance of bootstrapped time series. Let’s try increase number of clusters to decrease variance:

data_boot_km <- KMboot(ts(data_ts, freq = period), 100, k_range = c(14, 20))
data_plot <- data.table(Value = unlist(data_boot_km),
                        ID = rep(1:length(data_boot_km), each = length(data_ts)),
                        Time = rep(1:length(data_ts), length(data_boot_km))
                        )
 
ggplot(data_plot) +
  geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
  geom_line(data = data_plot[.(1), on = .(ID)], aes(Time, Value),
            color = "firebrick1", alpha = 0.9, size = 0.8) +
  theme_ts

We can see that the variance is much lower against MBB based methods. But we have still the power to increase it if we change the range of number of clusters.

The second proposed K-means based method is sampling new values randomly from Gaussian distribution based on parameters of created clusters (mean and variance). Let’s use it on our selected time series:

data_boot_km.norm <- KMboot.norm(ts(data_ts, freq = period), 100, k_range = c(12, 20))
data_plot <- data.table(Value = unlist(data_boot_km.norm),
                        ID = rep(1:length(data_boot_km.norm), each = length(data_ts)),
                        Time = rep(1:length(data_ts), length(data_boot_km.norm))
)
 
ggplot(data_plot) +
  geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
  geom_line(data = data_plot[.(1), on = .(ID)], aes(Time, Value),
            color = "firebrick1", alpha = 0.9, size = 0.8) +
  theme_ts

We can see nicely distributed values around the original time series, but will be it beneficial for forecasting?

We can also check all four bootstrapping methods in one plot by wrapper around above calls:

print_boot_series <- function(data, ntimes = 100, k_range = c(12, 20)) {
  
  data_boot_1 <- bld.mbb.bootstrap(data, ntimes)
  data_boot_2 <- smo.bootstrap(data, ntimes)
  data_boot_3 <- KMboot(data, ntimes, k_range = k_range)
  data_boot_4 <- KMboot.norm(data, ntimes, k_range = k_range)
  
  datas_all <- data.table(Value = c(unlist(data_boot_1), unlist(data_boot_2),
                                    unlist(data_boot_3), unlist(data_boot_4)),
                          ID = rep(rep(1:ntimes, each = length(data)), 4),
                          Time = rep(rep(1:length(data), ntimes), 4),
                          Method = factor(rep(c("MBB", "S.MBB", "KM", "KM.boot"),
                                              each = ntimes*length(data)))
  )
  
  datas_all[, Method := factor(Method, levels(Method)[c(3,4,1,2)])]
  
  print(ggplot(datas_all) +
          facet_wrap(~Method, ncol = 2) +
          geom_line(aes(Time, Value, group = ID), alpha = 0.5) +
          geom_line(data = datas_all[.(1), on = .(ID)], aes(Time, Value),
                    color = "firebrick1", alpha = 0.9, size = 0.8) +
          theme_ts)
 
}
 
print_boot_series(ts(hourly_M4[[200]]$x, freq = period))

When the time series is non-stationary, the clustering bootstrapping methods can oscillate little-bit badly. The clustering-based bootstrapping methods could be enhanced by for example differencing to be competitive (applicable) for non-stationary time series with a strong linear trend.

Forecasting with bootstrapping

For evaluating four presented bootstrapping methods for time series, to see which is the most competitive in general, experiments with 6 statistical forecasting methods were performed on all 414 hourly time series from the M4 competition dataset. Forecasts from bootstrapped time series were aggregated by the median. Also, simple base methods were evaluated alongside seasonal naive forecast. The six chosen statistical base forecasting methods were:

STL+ARIMA,
STL+ETS (both forecast package),
triple exponential smoothing with damped trend (smooth package - named ES (AAdA)),
Holt-Winters exponential smoothing (stats package),
dynamic optimized theta model (forecTheta package - named DOTM),
and standard theta model (forecast package).

Forecasting results were evaluated by sMAPE and ranks sorted by sMAPE forecasting accuracy measure.

The source code that generates forecasts from the all mentioned methods above and process results are available on my GitHub repository.

The first visualization of results shows mean sMAPE by base forecasting method:

ggplot(res_all[, .(sMAPE = mean(sMAPE, na.rm = TRUE)), by = .(Base_method, Boot_method)]) +
  facet_wrap(~Base_method, ncol = 3, scales = "fix") +
  geom_bar(aes(Boot_method, sMAPE, fill = Boot_method, color = Boot_method), alpha = 0.8, stat = "identity") +
  geom_text(aes(Boot_method, y = sMAPE + 1, label = paste(round(sMAPE, 2)))) +
  scale_fill_d3() +
  scale_color_d3() +
  theme_ts +
  theme(axis.text.x = element_text(angle = 60, hjust = 1))

Best methods based on average sMAPE are STL+ETS with s.MBB and DOTM with s.MBB bootstrapping. Our proposed s.MBB bootstrapping method won’s 5 times from 6 based on average sMAPE.

The next graph shows boxplot of Ranks:

ggplot(res_all) +
  facet_wrap(~Base_method, ncol = 3, scales = "fix") +
  geom_boxplot(aes(Boot_method, Rank, fill = Boot_method), alpha = 0.8) +
  scale_fill_d3() +
  theme_ts +
  theme(axis.text.x = element_text(angle = 60, hjust = 1))

We can see very tight results amongst base learners, MBB and s.MBB methods.

So, let’s see average Rank instead:

ggplot(res_all[, .(Rank = mean(Rank, na.rm = TRUE)), by = .(Base_method, Boot_method)]) +
  facet_wrap(~Base_method, ncol = 3, scales = "fix") +
  geom_bar(aes(Boot_method, Rank, fill = Boot_method, color = Boot_method), alpha = 0.8,
           stat = "identity") +
  geom_text(aes(Boot_method, y = Rank + 0.22, label = paste(round(Rank, 2))), size = 5) +
  scale_fill_d3() +
  scale_color_d3() +
  theme_ts +
  theme(axis.text.x = element_text(angle = 60, hjust = 1))

As was seen in the previous plot, it changes and it depends on a forecasting method, but very slightly better results have original MBB method over my s.MBB, but both beats base learner 5 times from 6. KM-based bootstraps failed to beat base learner 4 times from 6.

Let’s be more curious about distribution of Ranks…I will show you plot of Rank counts:

ggplot(res_all[, .(N = .N), by = .(Base_method, Boot_method, Rank)]
       [, Rank := factor(Rank)],
       aes(Boot_method, N)) +
  facet_wrap(~Base_method, ncol = 3, scales = "free") +
  geom_bar(aes(fill = Rank,
               color = Rank),
           alpha = 0.75, position = "dodge", stat = "identity") +
  scale_fill_d3() +
  scale_color_d3() +
  theme_ts +
  theme(axis.text.x = element_text(size = 10, angle = 60, hjust = 1))

We can see that KM-based bootstrapping can be first or second too! Around 25-times for each forecasting method were these 2 boot. methods first, and around 2-times more second…not that bad. Also, the seasonal naive forecast can be on some types of time series best against more sophisticated statistical forecasting methods… However, MBB and s.MBB methods are best and most of the time are in the first two ranks.

Conclusion

In this blog post, I showed you how to simply use four various bootstrapping methods on time series data. Then, the results of experiments performed on the M4 competition dataset were shown. Results suggest that bootstrapping can be very useful for improving forecasting accuracy.

References

[1] Bergmeir C., Hyndman R.J., Benitez J.M.: Bagging exponential smoothing methods using stl decomposition and box-cox transformation. International Journal of Forecasting, 32(2):303-312, (2016)

[2] Laurinec P., Loderer M., Lucka M. et al.: Density-based unsupervised ensemble learning methods for time series forecasting of aggregated or clustered electricity consumption, Journal Intelligent Information Systems, 53(2):219-239, (2019). DOI link