Search code examples
rmatrixpca

Rolling PCA and plotting proportional variance of principal components

I'm using the following code to perform PCA:

PCA <- prcomp(Ret1, center = TRUE, scale. = TRUE) 
summary(PCA)

I get the following result: 

#Importance of components:
#                          PC1    PC2     PC3     PC4
#Standard deviation     1.6338 0.9675 0.60446 0.17051
#Proportion of Variance 0.6673 0.2340 0.09134 0.00727
#Cumulative Proportion  0.6673 0.9014 0.99273 1.00000

What I would like to do is a Rolling PCA for a specific window ( e.g. 180 days). The Result should be a matrix which shows the evolution of the "Proportion of Variance" of all principal components though time.

I tried it with

rollapply(Ret1, 180, prcomp)

but this doesn't work and I have no Idea how to save the "Proportion of Variance" for each time step in matrix.

The output matrix should look like this: 

#          PC1    PC2     PC3     PC4
#Period 1  0.6673 0.2340 0.09134 0.00727
#Period 2  0.7673 0.1340 0.09134 0.00727
# ....

Here is a mini subset of my data Ret1:

             Cats            Dogs         Human           Frogs
2016-12-13  0.0084041063  6.518479e-03  6.096295e-04  5.781271e-03
2016-12-14 -0.0035340384 -8.150321e-03  4.418382e-04 -5.978296e-03
2016-12-15  0.0107522782  3.875708e-03 -1.784663e-02  3.012253e-03
2016-12-16  0.0033034130 -1.752174e-03 -1.753624e-03 -4.448850e-04
2016-12-17  0.0000000000  0.000000e+00  0.000000e+00  0.000000e+00
2016-12-18  0.0000000000  0.000000e+00  0.000000e+00  0.000000e+00
2016-12-19  0.0019876743  1.973190e-03 -8.577261e-03  1.996151e-03
2016-12-20  0.0033235161  3.630921e-03 -4.757395e-03  4.594355e-03
2016-12-21  0.0003401156 -2.460351e-03  3.708875e-03 -1.636413e-03
2016-12-22 -0.0010940147 -1.864724e-03 -7.991572e-03 -1.158029e-03
2016-12-23 -0.0005387228  1.250898e-03 -2.843725e-03  7.492594e-04
2016-12-24  0.0000000000  0.000000e+00  0.000000e+00  0.000000e+00
2016-12-25  0.0000000000  0.000000e+00  0.000000e+00  0.000000e+00
2016-12-26  0.0000000000  0.000000e+00  0.000000e+00  0.000000e+00
2016-12-27  0.0019465877  2.245918e-03  0.000000e+00  5.632058e-04
2016-12-28  0.0002396803 -8.391658e-03  8.307552e-03 -5.598988e-03
2016-12-29 -0.0020884556 -2.933868e-04  1.661246e-03 -7.010738e-04
2016-12-30  0.0026172923 -4.647865e-03  9.574997e-03 -2.889166e-03

I tried the following: 

PCA <- function(x){
  Output=cumsum((apply((prcomp(x,center = TRUE, scale. = TRUE))$x, 2, var))/sum(vars))
  return(Output)}

window <- 10
data <- Ret1
result <- rollapply(data, window,PCA)
plot(result)

#Gives you the Proportion of Variance = cumsum((apply((prcomp(x,center = TRUE, scale. = TRUE))$x, 2, var))/sum(vars))
Solution

  • First, the correct function for your purpose may be written as follow, using $sdev result of prcomp. I have left over center = TRUE and scale. = TRUE as they are function default.

    PCA <- function(x){
  oo <- prcomp(x)$sdev
  oo / sum(oo)
  }

    Now, we can easily use sapply to do rolling operation:

    ## for your mini dataset of 18 rows
window <- 10
n <- nrow(Ret1)
oo <- sapply(seq_len(n - window + 1), function (i) PCA(Ret1[i:(i + window - 1), ]))
oo <- t(oo)  ## an extra transposition as `sapply` does `cbind`

#           [,1]      [,2]       [,3]       [,4]
# [1,] 0.5206345 0.3251099 0.12789683 0.02635877
# [2,] 0.5722264 0.2493518 0.14588631 0.03253553
# [3,] 0.6051199 0.1973694 0.16151859 0.03599217
# [4,] 0.5195527 0.2874197 0.16497219 0.02805543
# [5,] 0.5682829 0.3100708 0.09456654 0.02707977
# [6,] 0.5344804 0.3149862 0.08912882 0.06140464
# [7,] 0.5954948 0.2542775 0.10434155 0.04588616
# [8,] 0.5627977 0.2581071 0.13068875 0.04840648
# [9,] 0.6089650 0.2559285 0.11022974 0.02487672

    Each column is a PC, while each row gives proportional variance for each component in that period.

    To further plot the result, you can use matplot:

    matplot(oo, type = "l", lty = 1, col = 1:4,
        xlab = "period", ylab = "proportional variance")

    enter image description here

    PCA 1-4 are sketched with colour 1:4, i.e., "black", "red", "green" and "blue".

    Additional comments:

    • If you want to use zoo::rollapply, do

      oo <- zoo::rollapply(Ret1, window, PCA, by.column = FALSE)

    • Precisely, I am reporting proportional standard deviation. If you really want proportional variance, chance PCA function to:

      PCA <- function(x){
  oo <- prcomp(x)$sdev ^ 2
  oo / sum(oo)
  }