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

Multiple Data (Time Series) Streams Clustering

Sun, 03 Feb 2019 00:00:00 +0000

Nowadays, data streams occur in many real scenarios. For example, they are generated from sensors, web traffic, satellites, and other interesting use cases. We have to process them in a fast way and extract from them as much knowledge as we can. Data streams have their own specific characteristics for processing and data mining. For example, they can be very fast, we can not process the whole history of data streams in memory, so we have to do it incrementally or in (e.g. sliding) windows.

In this post, I will cover one data streams clustering method that was developed by me. In R, you can do data stream clustering by stream package, BUT! there are methods only for one stream clustering (not multiple streams). However, I want to show you clustering of multiple data streams, so from multiple sources (e.g. sensors).

I created clustering method that is adapted for time series streams - called ClipStream [1]. This method is attribute based, so multiple attributes (features) are gathered from multiple streams windows. You can read more about it from my journal paper.

I will show you use case on smart meter data - electricity consumption time series (consumers) from London ( openly available here). Motivation for clustering such a data is to:

extract typical patterns of consumption,
detect outliers,
unsupervised classification of consumers,
create more forecastable groups of time series,
monitor changes and behavior.

The motivation to process them as streams is the fact that the data of electricity consumption (or production) are measured every 5, 15 or 30 minutes.

ClipStream has following steps (very briefly):

computing data streams representation for every stream (dimensionality reduction) - i.e. synopsis,
detect outlier (anomal) streams directly from extracted representations,
cluster non-outlier representations by K-medoids,
assign outlier streams to nearest clusters (medoids),
aggregate time series by clusters,
detect changes in aggregated time series.

In this post, I will mainly focus on the first 4 parts of my approach, since there are applicable to various use cases - not only on smart meter data and its forecasting. The whole method is developed in unsupervised fashion (yey!), so representation, clustering and outlier detection of time series streams are “learned” unsupervised.

Data exploration

Firstly, read the London smart meter data, which compromise more than 4000 consumers and load all the needed packages.

library(data.table)
library(parallel)
library(cluster)
library(clusterCrit)
library(TSrepr)
library(OpenML)
library(ggplot2)
library(grid)
library(animation)
library(gganimate)
library(av)

data <- OpenML::getOMLDataSet(data.id = 41060)
data <- data.matrix(data$data)

Let’s subset first 1000 consumers for more simple operations.

data_cons <- data[1:1000,]
period <- 48 # frequency of time series, every day 48 measurements are gathered

Let’s plot random consumer for better imagination.

ggplot(data.table(Time = 1:ncol(data_cons),
                  Value = data_cons[200,])) +
  geom_line(aes(Time, Value)) +
  labs(y = "Consumption (kWh)") +
  theme_ts

We can see stochastic behavior, but also some consumption pattern.

We can plot, for example, its average daily or weekly profile. We will do it by TSrepr’s package function repr_seas_profile.

ggplot(data.table(Time = 1:period,
                  Value = repr_seas_profile(data_cons[200,],
                                            freq = period,
                                            func = mean))) +
  geom_line(aes(Time, Value)) +
  geom_point(aes(Time, Value), alpha = 0.8, size = 2.5) +
  scale_x_continuous(breaks = seq(1, 48, 6),
                     labels = paste(seq(0, 23, by = 3), "h", sep = "")) +
  labs(y = "Consumption (kWh)") +
  theme_ts

The peak at the start of a day…

Now, let’s plot weekly pattern:

ggplot(data.table(Time = 1:(period*7),
                  Value = repr_seas_profile(data_cons[200,],
                                            freq = period*7,
                                            func = mean))) +
  geom_line(aes(Time, Value), size = 0.8) +
  geom_vline(xintercept = (0:7)*period, color = "dodgerblue2",
             size = 1.2, alpha = 0.7, linetype = 2) +
  labs(y = "Consumption (kWh)") +
  theme_ts

There is some change during a week.

Let’s explore the whole consumer base, but how when we have more than 1000 time series? We can cluster time series and just plot its daily patterns for example by created clusters. We will reduce the length of the visualized time series and also a number of time series in one plot.

First, extract average daily patterns, we will make it by repr_matrix function from TSrepr. Normalization of every consumer time series - row-wise by z-score is necessary! You can use your own normalization function (z-score and min-max methods are implemented).

data_ave_prof <- repr_matrix(data_cons,
                             func = repr_seas_profile,
                             args = list(freq = period,
                                         func = median),
                             normalise = TRUE,
                             func_norm = norm_z)

Let’s cluster computed mean daily profiles for example by K-means and to 12 clusters:

res_clust <- kmeans(data_ave_prof, 12, nstart = 20)

Preprocess clustering results with data.table package and plot them:

data_plot <- data.table(melt(data_ave_prof))
data_plot[, Clust := rep(res_clust$cluster, ncol(data_ave_prof))]
 
data_centroid <- data.table(melt(res_clust$centers))
data_centroid[, Clust := Var1]

ggplot(data_plot) +
  facet_wrap(~Clust, scales = "free", ncol = 3) +
  geom_line(aes(Var2, value, group = Var1), alpha = 0.7) +
  geom_line(data = data_centroid, aes(Var2, value, group = Var1),
            alpha = 0.8, color = "red", size = 1.2) +
  scale_x_continuous(breaks = c(1,seq(12, 48, 12)),
                     labels = paste(seq(0, 24, by = 6), "h", sep = "")) +
  theme_ts

Various interesting patterns of daily consumption!

BUT (here comes motivation)! When we would like to cluster just most recent data (for example 2-3 weeks), and update it regularly every day (or even thought half-hour), automatically detect changes in time series streams and detect anomalies (outlier consumers), detect automatically the number of clusters, and make it as quickly as possible… We can not do it like in the previous case, because of computational and memory load and also accuracy. Here comes on screen more sophisticated multiple data streams clustering methods. In ClipStream that uses FeaClip time series streams representation (see my previous post about time series represetnations), a representation can be computed incrementally, clusterings are computed in data batches, outliers are detected straight from representation and etc.

FeaClip is interpretable time series representation. It extracts 8 interpretable features from clipped representation (again please see the mentioned blog post). Let’s plot representation from one day consumption time series:

ts_feaclip <- repr_feaclip(data_cons[1, 1:48])
 
define_region <- function(row, col){
  viewport(layout.pos.row = row, layout.pos.col = col)
}
 
gg1 <- ggplot(data.table(Consumption = data_cons[1, 1:48],
                         Time = 1:48)) +
  geom_line(aes(Time, Consumption)) +
  geom_point(aes(Time, Consumption), size = 2, alpha = 0.8) +
  geom_hline(yintercept = mean(data_cons[1, 1:48]), color = "red", size = 0.8, linetype = 7) +
  theme_ts
 
gg2 <- ggplot(data.table(Count = ts_feaclip,
                         Time = 1:8)) +
  geom_line(aes(Time, Count)) +
  geom_point(aes(Time, Count), size = 2, alpha = 0.8) +
  scale_x_continuous(breaks = 1:8, labels = names(ts_feaclip)) +
  theme_ts
 
grid.newpage()
pushViewport(viewport(layout = grid.layout(2, 1)))
print(gg1, vp = define_region(1, 1))
print(gg2, vp = define_region(2, 1))

Let’s compute it also for consumption of length 2 weeks - by windows.

win <- 14
ts_feaclip_long <- repr_windowing(data_cons[1, 1:(period*win)],
                                  func = repr_feaclip, win_size = period)
 
means <- sapply(0:(win-1), function(i) mean(data_cons[1, ((period*i)+1):(period*(i+1))]))
means <- data.table(Consumption = rep(means, each = period),
                    Time = 1:length(data_cons[1, 1:(period*win)]))
 
gg1 <- ggplot(data.table(Consumption = data_cons[1, 1:(period*win)],
                         Time = 1:(period*win))) +
  geom_line(aes(Time, Consumption), alpha = 0.95) +
  geom_vline(xintercept = seq(from=period,to=(period*win)-period, by=period),
             alpha = 0.75, size = 1.0, col = "dodgerblue2", linetype = 2) +
  geom_line(data = means, aes(Time, Consumption), color = "firebrick2",
            alpha = 0.8, size = 1.2, linetype = 5) +
  labs(y = "Consumption (kWh)", title = NULL, x = NULL) +
  scale_x_continuous(breaks=seq(from=period/2, to=(period*win), by = period),
                     labels=c(1:win)) +
  theme_ts
 
gg2 <- ggplot(data.table(Count = ts_feaclip_long,
                         Time = 1:length(ts_feaclip_long))) +
  geom_line(aes(Time, Count)) +
  geom_vline(xintercept = seq(from=8,to=(8*win)-8, by=8),
             alpha = 0.75, size = 1.0, col = "dodgerblue2", linetype = 2) +
  # geom_point(aes(Time, Count), size = 2, alpha = 0.8) +
  scale_x_continuous(breaks=seq(from=8/2, to=(8*win), by = 8),
                     labels=c(1:win)) +
  labs(title = NULL, x = "Day") +
  theme_ts
 
grid.newpage()
pushViewport(viewport(layout = grid.layout(2, 1)))
print(gg1, vp = define_region(1, 1))
print(gg2, vp = define_region(2, 1))

We can see the typical pattern during working days and some changes when consumption goes high - the representation adapts to these changes, but not drastically - because of the average of a window (normalization).

FeaClip animation

Now, let’s play a little bit with gganimate and av packages and visualize the behavior of FeaClip through time (stream).

First, prepare whole one time series as a stream.

# Representation
data_feaclip_all <- repr_windowing(data_cons[1,],
                                   func = repr_feaclip,
                                   win_size = period)
win <- 14
win_size <- 14*8
n_win <- length(data_feaclip_all)/8 - win
data_feaclip_all_anim <- sapply(0:(n_win - 1), function(i) 
  data_feaclip_all[((i*8)+1):((i*8) + win_size)])
data_feaclip_all_anim <- data.table(melt(data_feaclip_all_anim))
data_feaclip_all_anim[, Type := "Representation - FeaClip"]
 
# Original TS
win <- 14
win_size <- 14*period
n_win <- ncol(data_cons)/period - win
data_cons_anim <- sapply(0:(n_win - 1), function(i) 
  data_cons[1, ((i*period)+1):((i*period) + win_size)])
row.names(data_cons_anim) <- NULL
data_cons_anim <- data.table(melt(data_cons_anim))
data_cons_anim[, Type := "Original TS"]
 
# Together
data_plot <- rbindlist(list(data_cons_anim,
                            data_feaclip_all_anim))
setnames(data_plot, "Var2", "Window")
 
data_vline <- data.table(Var1 = c(seq(from=period,to=(period*14)-period, by=period),
                                  seq(from=8,to=(8*14)-8, by=8)),
                         Type = rep(c("Original TS", "Representation - FeaClip"),
                                    each = 13)
                         )

Now, create ggplot animation object by ggplot and gganimate functions.

gg_anim <- ggplot(data_plot) +
  facet_wrap(~Type, scales = "free", ncol = 1) +
  geom_line(aes(Var1, value)) +
  geom_vline(data = data_vline, aes(xintercept = Var1),
             alpha = 0.75, size = 0.8, col = "dodgerblue2", linetype = 2) +
  labs(x = "Length", y = NULL,
       title = "Time series and its representation, Window: {frame_time}") +
  theme_ts +
  transition_time(Window)

Let’s animate!

gganimate::animate(gg_anim, fps = 2, nframes = n_win,
                   width = 720, height = 450, res = 120,
                   renderer = av_renderer('animation.mp4'))

We can see how FeaClip representation adapts on different behavior of electricity consumption - when it’s low around zero, or it gets high etc. - it makes drastic noise reduction and extracts only key features from the time series.

Multiple Data Streams

We already got a picture of one consumer time series stream. Let’s again play with the whole customer base (in our playing scenario with 1000 consumers). In this part, I would like to make nice animation of outlier detection and clustering phase in one image.

First iteration

Let’s get through the first iteration (window) of streams processing and clustering of ClipStream. So, first thing to do is to subset window of time series streams and compute FeaClip representations (the most recent window of length 14 days as in the previous case).

i = 0
data_win <- data_cons[, ((i*period)+1):((i+win)*period)]
 
data_clip <- repr_matrix(data_win, func = repr_feaclip,
                        windowing = T, win_size = period)

The second phase is an outlier detection from streams. This is done by “simple” IQR-quantile method from 2 key FeaClip features - Sum_1 and number of crossings. The source code for function detectOutliersIQR is in the ClipStream method repo. Let’s do it.

outliers <- detectOutliersIQR(data_clip, treshold = 1.5)

Let’s show outlier consumers with PCA:

pc_clip <- prcomp(data_clip, center = T, scale. = T)$x[,1:2]
pc_clip <- data.table(pc_clip,
                      Outlier = factor(outliers$class))
levels(pc_clip$Outlier) <- c("Outlier", "Normal")
 
ggplot(pc_clip) +
  geom_point(aes(PC1, PC2, fill = Outlier, shape = Outlier),
             size = 2.8, alpha = 0.75) +
  scale_shape_manual(values = c(24, 21)) +
  scale_fill_manual(values = c("salmon", "dodgerblue3")) +
  labs(title = paste("N.of.Outliers: " , nrow(pc_clip[Outlier == "Outlier"]))) +
  theme_ts

They are nicely located at the periphery of the feature space. Let’s find some outlier consumers and plot them:

which(pc_clip$PC2 == max(pc_clip$PC2))

## [1] 597

which(pc_clip$PC1 == min(pc_clip$PC1)) # zeros

## [1] 562 908 961

ggplot(data.table(Time = 1:ncol(data_win),
                  Value = data_win[which(pc_clip$PC2 == max(pc_clip$PC2)),])) +
  geom_line(aes(Time, Value)) +
  labs(y = "Consumption (kWh)") +
  theme_ts

ggplot(data.table(Time = 1:ncol(data_win),
                  Value = data_win[which(pc_clip$PC1 == min(pc_clip$PC1))[1],])) +
  geom_line(aes(Time, Value)) +
  labs(y = "Consumption (kWh)") +
  theme_ts

The first scenario is a consumer with a few large moments of high consumption and lot of crossings. The second scenario is the zero consumption type of a consumer.

The clustering phase is executed by an automatic K-medoids method. The number of clusters is automatically selected by the Davies-Bouldin index from the predefined range of clusters. We will cluster only non-outlier representations, for the reduction of data and also higher stability of clustering results.

# n.of.clusters range
k.min <- 8
k.max <- 15
 
clip_filtered <- data_clip[-outliers$outliers,]
clus_res <- clusterOptimKmedoidsDB(clip_filtered, k.min, k.max, 4,
                                   criterium = "Davies_Bouldin")
 
clustering <- outliers$class
clustering[which(clustering == 1)] <- clus_res$clustering

Let’s assign outliers to nearest clusters (i.e. to nearest medoids).

out_clust <- sapply(seq_along(outliers$outliers),
                    function(z) 
                      my_knn(clus_res$medoids,
                             as.numeric(data_clip[outliers$outliers[z],])))
 
clustering[which(clustering == 0)] <- out_clust

In the plot, average daily FeaClip representations will be plotted, because of the longer length of original FeaClip representation.

ave_clip <- repr_matrix(data_clip, func = repr_seas_profile,
                        args = list(freq = 8, func = mean))
data_plot <- data.table(melt(ave_clip))
data_plot[, Clust := rep(clustering, ncol(ave_clip))]
pc_clip[,Var1 := 1:.N]
data_plot[pc_clip[, .(Var1, Outlier)], Outlier := i.Outlier, on = .(Var1)]
 
medoids <- data.table(melt(repr_matrix(clus_res$medoids,
                                       func = repr_seas_profile,
                                       args = list(freq = 8, func = mean))))
medoids[, Clust := Var1]
 
ggplot(data_plot) +
  facet_wrap(~Clust, scales = "free", ncol = 3) +
  geom_line(aes(Var2, value, group = Var1, color = Outlier), alpha = 0.7) +
  geom_line(data = medoids, aes(Var2, value, group = Var1),
            alpha = 0.9, color = "dodgerblue2", size = 1) +
  labs(title = "Clusters of average daily FeaClip representations",
       y = "Count", x = NULL) +
  scale_x_continuous(breaks = 1:8, labels = c("m_1", "s_1", "m_0", "cr.",
                                              names(ts_feaclip)[5:8])) +
  scale_color_manual(values = c("salmon", "black")) +
  theme_ts

Nice distinguishable patterns.

Streaming

Now, let’s flow the data! I will make an update every new day during 50 days period and plot the results - detected outliers and clusters with also assigned outliers. The code is available on my GitHub repo. For full resolution - right click on the gif and click on the view image option.

We can see that the number of outliers and clusters dynamically changes through time (daily windows). You can build your own data streams clustering algorithm with a different streams representation - for example, see TSrepr list of methods.

Conclusion

In this post, I showed you how to process and cluster multiple seasonal time series streams with the ClipStream method. I showed you also detected outliers that were automatically found from the FeaClip representation. The results of clustering can be also used for improving forecasting accuracy of aggregated consumption. For more information, read my publications about this topic in the research section.

References

[1] Laurinec, P. & Lucká, M.: Interpretable multiple data streams clustering with clipped streams representation for the improvement of electricity consumption forecasting, Data Min Knowl Disc (2018). DOI link

My eRum 2018 biggest highlights

Sat, 19 May 2018 00:00:00 +0000

On the range of dates 14.-16. May 2018, the European R users meeting (eRum) was held in Budapest. I was there as an active participant since I had the presentation about time series data mining. The eRum 2018 was a very successful event and I want to thank organizers of this event for a great organization of it.

This blog post will be oriented on my biggest highlights of the eRum conference and as a list of useful resources.

Workshops

The eRum started with many workshops separated to 2 blocks and 7 parallel sessions (so together 14 workshops). It was difficult to choose 2 workshops from 14, in which I will sit because there were many interesting topics. I finally chose DALEX and Keras workshops.

DALEX - Descriptive mAchine Learning EXplanations

Great workshop by Przemyslaw Biecek and Mateusz Staniak about tools for exploration, validation, and explanation of complex machine learning models.

Fun on #workshop with DALEX to explain ML models at @erum2018 #erum2018 #rstats #dataviz #DataScience speaker: @smarterpoland pic.twitter.com/hHf9dThcr2
— Peter Laurinec (@petolauri) May 14, 2018

I learned many techniques for a diagnosis of machine learning models. Techniques for explanations of a trained model, predictions, single prediction etc. were all presented here. Workshop resources can be downloaded here:

DALEX_docs.

Various packages were used for these purposes, the list of them follows:

Deep learning with Keras

The second workshop that I attended was about using Keras for deep learning by Aimee Gott and Douglas Ashton. It was a nice workshop about the basic usage of Keras library in R. We had got through the use cases with Iris dataset and time series dataset from accelerometer (used CNN for training). The materials can be downloaded from here:

MangoTheCat/keras-workshop.

Conference talks

The second and the third day of the conference continued with keynote and invited talks, contributed talks and lightning talks. It was really motivating and inspirational to see all the R enthusiasts speak about their projects. It gives me more confidence to contribute to the R ecosystem or in the Data Science ecosystem in general. I will mention briefly 6 talks that were most fascinating to me.

The recipes package by Edwin Thoen helps in preprocessing (creating) of design (model) matrices. By recipes, you can create effective preprocessing “pipeline” for your data.

The bombshell by Florian Privé was about using large matrices in R. He created bigstats package for a parallel and fast manipulation of matrices with a larger size than RAM size.

The great keynote speech by Nathalie Vialaneix was about using unsupervised learning for relational data (or dissimilarity data). She talked about various interesting use cases to use her R packages adjclust and SOMbrero for clustering relational data. The slides can be found here: slides_villavialaneix_ERUM2018.

Unsupervised #learning for relational data, dissimilarities with #rstats packages adjclust and SOMbrero by @Natty_V2 #erum2018 #DataScience #MachineLearning
Great talk! pic.twitter.com/O73rzg7O1z
— Peter Laurinec (@petolauri) May 15, 2018

Afterward, Erin LeDell from H2O talked about automated ensemble learning using h2o package. The h2o.automl function allows various interesting things, for example, limit (restrict) learning time for a creation of ensemble.

The great machine learning session continued with a talk by Szilard Pafka. His benchmark repositories are well known in the ML community. He talked about gradient boosting frameworks (h2o.gbm, xgboost, lightGBM), and their pros and cons (see repo GBM-perf).

The next day was most interesting for me talk by Henrik Bengtsson about parallel computing in R. His future package allows async parallel multiprocessing computing. It has many various useful applications, for example in shiny apps.

TSrepr talk

As I mentioned in the beginning, I also gave a talk about my TSrepr package. I talked about how to use time series representations to do better data mining in R. Slides are here:

Time series representations for better data mining from Peter Laurinec

The video of the talk:

You can read more about how to use time series representation methods in my previous blog posts:

All other talks can be seen on Budapest Users of R Network channel!

TSrepr use case - Clustering time series representations in R

Tue, 13 Mar 2018 00:00:00 +0000

In the previous blog post, I showed you usage of my TSrepr package. There was shown what kind of time series representations are implemented and what are they good for.

In this tutorial, I will show you one use case how to use time series representations effectively. This use case is clustering of time series and it will be clustering of consumers of electricity load.

By clustering of consumers of electricity load, we can extract typical load profiles, improve the accuracy of consequent electricity consumption forecasting, detect anomalies or monitor a whole smart grid (grid of consumers) (Laurinec et al. (2016), Laurinec and Lucká (2016)). I will show you the first use case, the extraction of typical electricity load profiles by K-medoids clustering method.

Firstly, let’s load the required packages, data (elec_load) and return the dimensions of the dataset.

library(TSrepr)
library(ggplot2)
library(data.table)
library(cluster)
library(clusterCrit)
 
data("elec_load")
dim(elec_load)

## [1]  50 672

There are 50 time series (consumers) of length 672, specifically time series of length 2 weeks of electricity consumption. These measurements are from smart meters from an unknown country.

It is obvious that dimensionality is too high and the curse of dimensionality can happen. For this reason, we have to reduce dimensionality in some way. One of the best approaches is to use time series representations in order to reduce dimensionality, reduce noise and emphasize the main characteristics of time series.

For double seasonal time series of electricity consumption (daily and weekly seasonality), the model-based representation approaches seem to have best ability to extract typical profiles of consumption. However, I will use some other representation methods implemented in TSrepr too.

Let’s use one of the basic model-based representation methods - mean seasonal profile. It is implemented in the repr_seas_profile function and we will use it alongside repr_matrix function that computes representations for every row of a matrix of time series. One more very important notice here, normalisation of time series is a necessary procedure before every clustering or classification of time series. It is due to a fact that we want to extract typical curves of consumption and don’t cluster based on an amount of consumption. By using the TSrepr package, we can do it all in one function - repr_matrix. We will use z-score normalisation implemented in norm_z function. We have 48 measurements during a day, so set freq = 48.

data_seasprof <- repr_matrix(elec_load, func = repr_seas_profile,
                             args = list(freq = 48, func = mean),
                             normalise = TRUE, func_norm = norm_z)
dim(data_seasprof)

## [1] 50 48

We can see that dimensionality was in fact reduced significantly. Now, let’s use the K-medoids (pam function from cluster package) clustering method to extract typical consumption profiles. Since we don’t know a proper number of clusters to create, i.e. a priori information about a number of clusters, an internal validation index is have to be used to determine an optimal number of clusters. I will use well known Davies-Bouldin index for this evaluation. By Davies-Bouldin index computation, we want to find a minimum of its values.

I will set the range of number of clusters to 2-7.

clusterings <- lapply(c(2:7), function(x)
                  pam(data_seasprof, x))
 
DB_values <- sapply(seq_along(clusterings), function(x) 
                  intCriteria(data_seasprof, as.integer(clusterings[[x]]$clustering),
                              c("Davies_Bouldin")))

Let’s plot results of internal evaluation.

ggplot(data.table(Clusters = 2:7, DBindex = unlist(DB_values)),
       aes(Clusters, DBindex)) +
  geom_line(size = 1) +
  geom_point(size = 3) +
  theme_bw()

The “best” number of clusters is 7 (lowest value of the index).

Let’s plot the results of clustering with 7 number of clusters. I will use computed medoids stored in the object clustering. For a visualization, the facet_wrap function is very handy here.

# prepare data for plotting
data_plot <- data.table(melt(data.table(class = as.factor(clusterings[[6]]$clustering),
                                        data_seasprof)))
data_plot[, Time := rep(1:ncol(data_seasprof), each = nrow(data_seasprof))]
data_plot[, ID := rep(1:nrow(data_seasprof), ncol(data_seasprof))]
 
# prepare medoids
centers <- data.table(melt(clusterings[[6]]$medoids))
setnames(centers, c("Var1", "Var2"), c("class", "Time"))
centers[, ID := class]
 
# plot the results
ggplot(data_plot, aes(Time, value, group = ID)) +
  facet_wrap(~class, ncol = 2, scales = "free_y") +
  geom_line(color = "grey10", alpha = 0.65) +
  geom_line(data = centers, aes(Time, value),
            color = "firebrick1", alpha = 0.80, size = 1.2) +
  labs(x = "Time", y = "Load (normalised)") +
  theme_bw()

We can see 5 typical extracted profiles - red lines (medoids of clusters). The next two clusters are one-elemental, so they can be referred as outliers.

Now, let’s try some more sophisticated method for the extraction of seasonal profiles - GAM regression coefficients. By repr_gam function, we can extract double seasonal regression coefficients - daily and weekly (you can read more about the analysis of seasonal time series with GAM here). However, the number of weekly seasonal regression coefficients will be only 6, because the number of the second seasonality coefficients is set to freq_2 / freq_1, so 48*7 / 48 = 7, and 7 - 1 = 6 because of splines computation (differentiation). I will again use repr_matrix function.

data_gam <- repr_matrix(elec_load, func = repr_gam, args = list(freq = c(48, 48*7)),
                        normalise = TRUE, func_norm = norm_z)
dim(data_gam)

## [1] 50 53

So the dimension is 47 + 6 = 53 because of usage of splines in GAM method. Let’s cluster the data and visualize results of it.

clusterings <- lapply(c(2:7), function(x)
                  pam(data_gam, x))
 
DB_values <- sapply(seq_along(clusterings), function(x) 
                  intCriteria(data_gam, as.integer(clusterings[[x]]$clustering),
                              c("Davies_Bouldin")))

Let’s plot results of internal evaluation.

ggplot(data.table(Clusters = 2:7, DBindex = unlist(DB_values)),
       aes(Clusters, DBindex)) +
  geom_line(size = 1) +
  geom_point(size = 3) +
  theme_bw()

The optimal number of clusters is again 7. Let’s plot results.

# prepare data for plotting
data_plot <- data.table(melt(data.table(class = as.factor(clusterings[[6]]$clustering),
                                        data_gam)))
data_plot[, Time := rep(1:ncol(data_gam), each = nrow(data_gam))]
data_plot[, ID := rep(1:nrow(data_gam), ncol(data_gam))]
 
# prepare medoids
centers <- data.table(melt(clusterings[[6]]$medoids))
setnames(centers, c("Var1", "Var2"), c("class", "Time"))
centers[, ID := class]
 
# plot the results
ggplot(data_plot, aes(Time, value, group = ID)) +
  facet_wrap(~class, ncol = 2, scales = "free_y") +
  geom_line(color = "grey10", alpha = 0.65) +
  geom_line(data = centers, aes(Time, value),
            color = "firebrick1", alpha = 0.80, size = 1.2) +
  geom_vline(xintercept = 46, color = "dodgerblue2",
             size = 1.4, linetype = 5, alpha = 0.8) +
  labs(x = "Time", y = "Load (normalised)") +
  theme_bw()

That is a more delightful result, isn’t it? Extracted consumption profiles are smoother than in the case of average seasonal profiles. The blue dashed line borders daily and weekly seasonal coefficients. The K-medoids now extracted 4 typical profiles and determined 3 one-element clusters.

I will show you also result of clustering of some nondata adaptive representation, let’s pick for example DFT (Discrete Fourier Transform) method and extract first 48 DFT coefficients.

data_dft <- repr_matrix(elec_load, func = repr_dft, args = list(coef = 48),
                        normalise = TRUE, func_norm = norm_z)
dim(data_dft)

## [1] 50 48

clusterings <- lapply(c(2:7), function(x)
                  pam(data_dft, x))
 
DB_values <- sapply(seq_along(clusterings), function(x) 
                  intCriteria(data_dft, as.integer(clusterings[[x]]$clustering),
                              c("Davies_Bouldin")))

Let’s plot results of internal evaluation.

ggplot(data.table(Clusters = 2:7, DBindex = unlist(DB_values)),
       aes(Clusters, DBindex)) +
  geom_line(size = 1) +
  geom_point(size = 3) +
  theme_bw()

We can see nice “elbow” here at 4 number of clusters.

# prepare data for plotting
data_plot <- data.table(melt(data.table(class = as.factor(clusterings[[3]]$clustering),
                                        data_dft)))
data_plot[, Time := rep(1:ncol(data_dft), each = nrow(data_dft))]
data_plot[, ID := rep(1:nrow(data_dft), ncol(data_dft))]
 
# prepare medoids
centers <- data.table(melt(clusterings[[3]]$medoids))
setnames(centers, c("Var1", "Var2"), c("class", "Time"))
centers[, ID := class]
 
# plot the results
ggplot(data_plot, aes(Time, value, group = ID)) +
  facet_wrap(~class, ncol = 2, scales = "free_y") +
  geom_line(color = "grey10", alpha = 0.65) +
  geom_line(data = centers, aes(Time, value),
            color = "firebrick1", alpha = 0.80, size = 1.2) +
  labs(x = "Time", y = "Load (normalised)") +
  theme_bw()

The interpretability of these results would be difficult. Therefore, model-based time series representations are very effective in this use case (so the typical profiles extraction).

I will show you the usage of one more representation method - FeaClip. The FeaClip is feature extraction method from a clipped representation (Laurinec and Lucká (2018)). The windowing approach alongside FeaClip is recommended to use for every day of time series. The big advantage is that normalisation is not needed alongside FeaClip method. Let’s use it in our case. The windowing method is also directly implemented in repr_matrix function.

data_feaclip <- repr_matrix(elec_load, func = repr_feaclip,
                            windowing = TRUE, win_size = 48)
 
dim(data_feaclip)

## [1]  50 112

clusterings <- lapply(c(2:7), function(x)
                  pam(data_feaclip, x))
 
DB_values <- sapply(seq_along(clusterings), function(x) 
                  intCriteria(data_feaclip, as.integer(clusterings[[x]]$clustering),
                              c("Davies_Bouldin")))

Let’s plot results of internal evaluation.

ggplot(data.table(Clusters = 2:7, DBindex = unlist(DB_values)),
       aes(Clusters, DBindex)) +
  geom_line(size = 1) +
  geom_point(size = 3) +
  theme_bw()

We can see that now 2 “elbows” appeared. The biggest change is between 2 and 3 number of clusters, so I will choose number 3.

# prepare data for plotting
data_plot <- data.table(melt(data.table(class = as.factor(clusterings[[2]]$clustering),
                                        data_feaclip)))
data_plot[, Time := rep(1:ncol(data_feaclip), each = nrow(data_feaclip))]
data_plot[, ID := rep(1:nrow(data_feaclip), ncol(data_feaclip))]
 
# prepare medoids
centers <- data.table(melt(clusterings[[2]]$medoids))
setnames(centers, c("Var1", "Var2"), c("class", "Time"))
centers[, ID := class]
 
# plot the results
ggplot(data_plot, aes(Time, value, group = ID)) +
  facet_wrap(~class, ncol = 2, scales = "free_y") +
  geom_line(color = "grey10", alpha = 0.65) +
  geom_line(data = centers, aes(Time, value),
            color = "firebrick1", alpha = 0.80, size = 1.2) +
  labs(x = "Time", y = "Load (normalised)") +
  theme_bw()

It seems like good separability of clusters, better than in the case of DFT. But you can check also other results of clusterings with the different number of clusters.

Conclusion

In this tutorial, I showed you the usage of time series representation methods to create more characteristic profiles of consumers. Then, time series representations, calculated by TSrepr package, were clustered by K-medoids and typical consumption profiles were extracted from created clusters.

Time series representations can be helpful also in other use cases as classification or time series indexing. You can check how I use time series representations in my dissertation thesis in more detail on the research section of this site.

References

Laurinec, Peter, and Mária Lucká. 2016. “Comparison of Representations of Time Series for Clustering Smart Meter Data.” In Lecture Notes in Engineering and Computer Science: Proceedings of the World Congress on Engineering and Computer Science 2016, 458–63.

Laurinec, Peter, Marek Lóderer, Petra Vrablecová, Mária Lucká, Viera Rozinajová, and Anna Bou Ezzeddine. 2016. “Adaptive Time Series Forecasting of Energy Consumption Using Optimized Cluster Analysis.” In Data Mining Workshops (Icdmw), 2016 Ieee 16th International Conference on, 398–405. IEEE.

Laurinec, Peter, and Mária Lucká. 2018. “Interpretable multiple data streams clustering with clipped streams representation for the improvement of electricity consumption forecasting”. Data Mining and Knowledge Discovery. Springer. DOI: 10.1007/s10618-018-0598-2.

TSrepr - Time Series Representations in R

Fri, 26 Jan 2018 00:00:00 +0000

I’m happy to announce a new package that has recently appeared on CRAN, called “TSrepr” (version 1.0.0: https://CRAN.R-project.org/package=TSrepr).

The TSrepr package contains methods of time series representations (dimensionality reduction, feature extraction or preprocessing) and several other useful helper methods and functions.

Time series representation can be defined as follows:

Let $ x $ be a time series of length $ n $, then representation of $ x $ is a model $ \hat{x} $ with reduced dimensionality $ p $ $ (p < n) $ such that $ \hat{x} $ approximates closely $ x $ (Esling and Agon (2012)).

Time series representations are used for:

significant reduction of the time series dimensionality
emphasis on fundamental (essential) shape characteristics
implicit noise handling
reducing the dimension will reduce memory requirements and computational complexity of consequent machine learning methods.

Therefore, they are awesome!

Time series representation methods can be divided into four groups (types) (Ratanamahatana et al. (2005)):

nondata adaptive
data adaptive
model-based
data dictated (clipped data).

In nondata adaptive representations, the parameters of transformation remain the same for all time series, irrespective of their nature. In data adaptive representations, the parameters of transformation vary depending on the available data. An approach to the model-based representation relies on the assumption that the observed time series was created based on basic model. The aim is to find the parameters of such a model as a representation. Two time series are then considered as similar if they were created by the same set of parameters of a basic model. In data dictated approaches, the compression ratio is defined automatically based on raw time series such as clipped (Aghabozorgi, Seyed Shirkhorshidi, and Ying Wah (2015)).

Most famous (well known) methods for nondata adaptive type of representations are PAA (Piecewise Aggregate Approximation), DWT (Discrete Wavelet Transform), DFT (Discrete Fourier Transform), DCT (Discrete Cosine Transform) or PIP (Perceptually Important Points). For data adaptive type of representations, it is SAX (Symbolic Aggregate approXimation), PLA (Piecewise Linear Approximation) and SVD (Singular Value Decomposition). For model-based representations it is ARMA, mean profiles or estimated regression coefficients from a statistical model (e.g. linear model). The data dictated is the less known type of representation and the most famous method of this type is clipping (bit-level) representation (Bagnall et al. (2006)).

Implemented methods and functions

In the TSrepr package, these time series representation methods are implemented (the function names are in brackets):

Nondata adaptive:
- PAA - Piecewise Aggregate Approximation (repr_paa)
- DWT - Discrete Wavelet Transform (repr_dwt)
- DFT - Discrete Fourier Transform (repr_dft)
- DCT - Discrete Cosine Transform (repr_dct)
- SMA - Simple Moving Average (repr_sma)
- PIP - Perceptually Important Points (repr_pip)
Data adaptive:
- SAX - Symbolic Aggregate Approximation (repr_sax)
- PLA - Piecewise Linear Approximation (repr_pla)
Model-based:
- Mean seasonal profile - Average seasonal profile, Median seasonal profile, etc. (repr_seas_profile)
- Model-based seasonal representations based on linear (additive) model (LM, RLM, L1, GAM) (repr_lm, repr_gam)
- Exponential smoothing seasonal coefficients (repr_exp)
Data dictated:
- FeaClip - Feature extraction from clipping representation (repr_feaclip, clipping)
- FeaTrend - Feature extraction from trending representation (repr_featrend, trending)
- FeaClipTrend - Feature extraction from clipping and trending representation (repr_feacliptrend)

Some additional useful functions are also implemented in the TSrepr package, such as:

Windowing (repr_windowing) - applies to the above mentioned representations to every window of a time series
Matrix of representations (repr_matrix) - applies to the above mentioned representations to every row of a matrix of time series
Normalisation functions - z-score (norm_z), min-max (norm_min_max)
Normalisation functions with output also of scaling parameters - z-score (norm_z_list), min-max (norm_min_max_list)
Denormalisation functions - z-score (denorm_z), min-max (denorm_min_max)
Forecasting accuracy measures - MAE, RMSE, MdAE, MAPE, sMAPE, MASE.

Usage of the TSrepr package

The TSrepr functions can be used very easily. The input is always a numeric vector (univariate time series) and additional arguments can occur in some methods.

Let’s load the package and ggplot2 for visualizations:

# install.packages("TSrepr")
library(TSrepr)
library(ggplot2)

Let’s load electricity consumption data (elec_load) and use first time series from the dataset. There is 672 values, so 14 days of measurements.

data("elec_load")
 
data_ts <- as.numeric(elec_load[1,])
 
ggplot(data.frame(Time = 1:length(data_ts), Value = data_ts), aes(Time, Value)) +
  geom_line() +
  theme_bw()

Now, we want to for example reduce dimensionality and reduce the noise of our time series. We can of course, use the time series representations from the TSrepr package. We can compare multiple methods here that are suitable for this task (smoothing of highly noised time series), for example, PAA, DWT, DFT or DCT. We will reduce dimensionality 8 times, so from 672 to 84.

# DWT with level of 2^3
data_dwt <- repr_dwt(data_ts, level = 3)
# first 84 DFT coefficients are extracted and then inverted
data_dft <- repr_dft(data_ts, coef = 84)
# first 84 DCT coefficients are extracted and then inverted
data_dct <- repr_dct(data_ts, coef = 84)
# Classical PAA
data_paa <- repr_paa(data_ts, q = 8, func = mean)

Let’s plot the results:

data_plot <- data.frame(Value = c(data_dwt, data_dft, data_dct, data_paa),
                        Time = rep(1:length(data_dwt), 4),
                        Method = factor(rep(c("DWT", "DFT", "DCT", "PAA"),
                                            each = length(data_dwt))))
 
ggplot(data_plot, aes(Time, Value, color = Method)) +
  geom_line(alpha = 0.80, size = 0.8) +
  theme_bw()

We can see that the electricity consumption pattern remains also after significant reduction of dimensionality. The difference between these four representation methods is not really significant, every one of them “did the job” well.

For seasonal time series as electricity load data, the model-based representations are highly recommended (Laurinec et al. (2016), Laurinec and Lucká (2016)). By model-based representation, we can extract a daily profile of some consumer. We can do it by simple average (or median) daily profile or by extraction of seasonal regression coefficients.

For this task, several methods are implemented in the TSrepr package. The mean seasonal profile (repr_seas_profile), seasonal linear models (repr_lm), seasonal additive model (repr_gam) or seasonal exponential smoothing coefficients (repr_exp). Let’s compare them on our data.

data_lm <- repr_lm(data_ts, freq = 48, method = "lm")
# robust linear model and l1 regression are also implemented
data_l1 <- repr_lm(data_ts, freq = 48, method = "l1")
# GAM
data_gam <- repr_gam(data_ts, freq = 48)
# median seasonal profile
data_seas_prof <- repr_seas_profile(data_ts, freq = 48, func = median)
# exponential smoothing
data_exp <- repr_exp(data_ts, freq = 48)

And let’s plot the results:

data_plot <- data.frame(Value = c(data_lm, data_l1, data_seas_prof, data_exp, data_gam),
                        Time = c(rep(1:length(data_lm), 4), 1:length(data_gam)),
                        Method = c(rep(c("LM", "L1", "Median seas. prof.", "Exp. smooth."),
                                       each = 48), rep("GAM", 47)))
 
ggplot(data_plot, aes(Time, Value, color = Method)) +
  geom_line(alpha = 0.80, size = 0.8) +
  theme_bw()

We can see that the most fluctuate result has exponential smoothing representation and the most smooth (denoised) result has seasonal GAM representation. Median daily profile and seasonal L1 regression coefficients are almost identical, the seasonal linear model regression coefficients representation is similar to them, but not that smooth.

There are also two similar time series representation methods in TSrepr package that extract important points from time series - PIP and PLA. Let’s try it on our data, and we will extract 60 points from the original time series (there will be 61 points in the end because of the nature of these methods). If we set return = "both", then data.frame with both places and points will be returned.

data_pip <- repr_pip(data_ts, times = 60, return = "both")
data_pla <- repr_pla(data_ts, times = 60, return = "both")

And, of course, let’s plot the results.

data_plot <- data.frame(Value = c(data_ts, data_pip$points, data_pla$points),
                        Time = c(1:length(data_ts), data_pip$places, data_pla$places),
                        Method = c(rep("Original", length(data_ts)),
                                   rep(c("PIP", "PLA"), each = length(data_pla$places))))
 
ggplot(data_plot, aes(Time, Value, color = Method)) +
  geom_line(alpha = 0.65, size = 0.8) +
  theme_bw()

We can see some significant differences among these two methods, but both approaches identified important points well.

The next data adaptive representation method is SAX. The SAX is a famous time series representation method – for its adaptability and originality. It extracts symbols as representation, in other words, it transforms aggregates of a time series to alphabetical symbols. Let’s use it on our data:

# aggregates of size 12 and alphabet of size 10
repr_sax(data_ts, q = 12, a = 10)

##  [1] "g" "i" "g" "j" "g" "j" "j" "j" "f" "i" "j" "j" "f" "h" "j" "j" "f"
## [18] "i" "h" "h" "f" "i" "i" "i" "f" "i" "f" "i" "f" "g" "g" "i" "f" "i"
## [35] "g" "h" "f" "f" "f" "i" "h" "h" "f" "i" "f" "g" "f" "i" "f" "h" "g"
## [52] "i" "f" "h" "g" "i"

The last type of implemented representation methods is the data dictated - clipped. I developed two methods in this category - FeaClip and FeaTrend. Both creates bit-level (binary) representation from original time series and computes run lengths of values by RLE (Run Length Encoding). Then interpretable features are extracted from run lengths.

I will now describe the first of the mentioned methods - FeaClip (Laurinec and Lucká (2018)). Clipping representation is created very easily - if a value of a time series is greater then its average value, then the value is transformed to 1 and otherwise to 0. It can be defined formally as follows:

\[\hat{x}_t = \left\{ \begin{array}{rl} 1 & \text{if } x_t > \mu \\ 0 & \text{otherwise} \end{array} \right. ,\]

where $\mu$ is the average value of a time series. On clipping (bit-level) representation $\hat{x}$, compression method for binary series named Run Length Encoding (RLE) is applied. A run is continuous sequence of ones, respectively zeros. The number of ones respectively zeros in a run we call the run lengths. From run lengths counted by RLE, eight simple interpretable features are extracted to form the final representation and are defined as

\[\begin{aligned} \mathbf{repr} = \{ & max_1 = \mbox{max. from run lengths of ones}, \\ & sum_1 = \mbox{sum of run lengths of ones}, \\ & max_0 = \mbox{max. from run lengths of zeros}, \\ & jumps = \mbox{length of RLE encoding} - 1, \\ & 0_{1.} = \mbox{number of first zeros}, \\ & 0_{n.} = \mbox{number of last zeros}, \\ & 1_{1.} = \mbox{number of first ones}, \\ & 1_{n.} = \mbox{number of last ones}, \} . \end{aligned}\]

Now, I will use methods implemented in TSrepr package to show you how it works. The clipped series is created by function clipping, I will only extract the first day from the electricity consumption time series.

data_oneday <- data_ts[1:48]
clipping(data_oneday)

##  [1] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1
## [36] 1 1 0 0 0 0 1 1 1 1 1 0 0

If we visualize the data with its average value, then we can see that it works as the definition above:

ggplot(data.frame(Time = 1:length(data_oneday), Value = data_oneday), aes(Time, Value)) +
  geom_line() +
  geom_line(data = data.frame(Time = 1:length(data_oneday), Value = mean(data_oneday)), aes(Time, Value), color = "red", size = 1, alpha = 0.8) +
  theme_bw()

Then RLE is used for the extraction of run lengths:

rleC(clipping(data_oneday))

## $lengths
## [1] 16  3 15  3  4  5  2
## 
## $values
## [1] 0 1 0 1 0 1 0

And finally, the extraction of interpretable features and all previous procedures is implemented in the repr_feaclip function:

repr_feaclip(data_oneday)

## max_1 sum_1 max_0 jumps  0_1.  0_n.  1_1.  1_n. 
##     5    11    16     6    16     2     0     0

The FeaClip method is recommended to use with windowing approach, so for every specified window the FeaClip computation is separately applied (Laurinec and Lucká (2018)). For the electricity consumption data, I am using the length of the window equal to 1 day so 48 measurements. The windowing method is implemented by function repr_windowing and its arguments are representation function (func), window size (win_size) and list of additional arguments to representation function (args). Let’s use it in our case:

data_feaclip <- repr_windowing(data_ts, func = repr_feaclip, win_size = 48)
 
ggplot(data.frame(Time = 1:length(data_feaclip), Value = data_feaclip), aes(Time, Value)) +
  geom_line() +
  theme_bw()

The second data dictated method is FeaTrend. It extracts features from “trending” (again binary) representation. The trending representation is defined as follows:

\[\hat{x}_t = \left\{ \begin{array}{rl} 1 & \text{if } x_t - x_{t+1} < 0 \\ 0 & \text{otherwise} \end{array} \right. .\]

So, when time series value increased then it is 1, otherwise it is 0.

Before the computation of trending representation, a time series is smoothed (denoised) by simple moving average method (repr_sma) in order to have more compact run lengths. Let’s demonstrate this factor in our example case, so we will use trending and RLE function on original and also on the smoothed time series:

# original time series
rleC(trending(data_oneday))

## $lengths
##  [1] 2 2 2 2 1 2 2 4 2 2 1 1 1 2 2 2 1 4 4 4 4
## 
## $values
##  [1] 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0

# smoothed time series by SMA
rleC(trending(repr_sma(data_oneday, order = 4)))

## $lengths
##  [1] 6 2 2 4 5 4 2 1 2 5 3 5 2
## 
## $values
##  [1] 0 1 0 1 0 1 0 1 0 1 0 1 0

As expected, the run lengths of smoothed time series are more compact. The FeaTrend is designed to extract an arbitrary feature from run lengths of a trending representation. The recommended feature is the maximum value of zeros and ones, but it can vary from an application. In the repr_featrend function, the windowing is directly implemented, so the original time series is divided into pieces (subseries) and features are extracted from them separately. Let’s try it in our case, but at first we will smooth original time series data_ts dramatically by SMA (order of moving average will be 48*7, so weekly seasonality) and do it only on whole time series (pieces = 1).

# visualize smoothed time series
data_sma <- repr_sma(data_ts, order = 48*7)
ggplot(data.frame(Time = 1:length(data_sma), Value = data_sma), aes(Time, Value)) +
  geom_line() +
  theme_bw()

# compute FeaTrend representation
repr_featrend(data_ts, func = max, pieces = 1, order = 48*7)

## [1] 15 30

So, the maximal run length of ones is 15 and maximal run length of zeros is 30, as expected, the number of zeros is much more than the number of ones because of decreasing character of the used time series.

And we have described and used every time series representation method implemented in the TSrepr package. In the next post (tutorial), I will show you one typical use case for using time series representation – clustering of time series.

References

Aghabozorgi, Saeed, Ali Seyed Shirkhorshidi, and Teh Ying Wah. 2015. “Time-series clustering - A decade review.” Information Systems 53. Elsevier: 16–38.

Bagnall, Anthony, Chotirat Ratanamahatana, Eamonn Keogh, Stefano Lonardi, and Gareth Janacek. 2006. “A bit level representation for time series data mining with shape based similarity.” Data Mining and Knowledge Discovery 13 (1): 11–40.

Esling, Philippe, and Carlos Agon. 2012. “Time-series data mining.” ACM Computing Surveys 45 (1). ACM: 1–34.

Ratanamahatana, Chotirat, Eamonn Keogh, Anthony J Bagnall, and Stefano Lonardi. 2005. “A Novel Bit Level Time Series Representation with Implication of Similarity Search and Clustering.” In Pacific-Asia Conference on Knowledge Discovery and Data Mining, 771–77. Springer.