滚动 PCA 并绘制主成分的比例方差

Question

我正在使用以下代码执行 PCA：

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

我得到以下结果：

#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

我想做的是针对特定窗口（例如 180 天）的滚动 PCA。结果应该是一个矩阵，显示所有主成分的“方差比例”随时间的演变。

我试过了

rollapply(Ret1, 180, prcomp)

但这不起作用，我不知道如何为矩阵中的每个时间步保存“方差比例”。

输出矩阵应如下所示：

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

这是我的数据的一个小子集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

我尝试了以下方法：

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))

Answer 1

首先，使用prcomp 的结果$sdev 可以编写如下用于您目的的正确函数。我留下了center = TRUE 和scale. = TRUE，因为它们是函数默认值。

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

现在，我们可以很方便地使用sapply进行滚动操作了：

## 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

每一列是一个 PC，而每一行给出了该时期每个组件的比例方差。

要进一步绘制结果，您可以使用matplot：

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

PCA 1-4 以 1:4 的颜色绘制，即“黑色”、“红色”、“绿色”和“蓝色”。

---

其他 cmets：

• 如果你想使用zoo::rollapply，请这样做

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

• 准确地说，我报告的是比例标准偏差。如果你真的想要比例方差，机会PCA 函数：

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