Question

我想用R来估算固定数量的特征向量的每日解释方差（这与＆＃34;吸收率＆＃34;由Kritzman等人在this article中定义）相同。我使用this data file，这是每日回报的矩阵。我的主要目标是以与Kritzman等人在上面的文章中所做的相同的方式估计每日解释的方差（吸收率）。据估计，Kritzman等人说：

为了估算吸收率，我们使用500天的 [rolling] 窗口来估计协方差矩阵和特征向量，并且我们将特征向量的数量固定为大约1 / 5我们样本中的资产数量。

为了在R中计算，我尝试了以下代码：

rm(list=ls(all=TRUE))
library("quadprog")

# read data set consisting of daily returns
data <- read.table("10_Industry_Portfolios_Daily.txt", header=TRUE)
Ret <- data[,2:ncol(data)]/100
names <- c("NoDur","Durbl","Manuf","Enrgy","HiTec",
           "Telcm","Shops","Hlth","Utils","Other")
colnames(Ret) <- names

# lookback period in number of days (rolling window)
lb.period <- 500
nRow <- nrow(Ret)
nCol <- ncol(Ret)
n <- nRow-lb.period

ar <- rep(0,n) # reserve space for daily absorption ratio
for(i in 1:n) {
# define rolling window
  start <- i
  end <- i+lb.period-1
  ret <- Ret[start:end,]
  cov <- cov(ret)
  eigenval <- eigen(cov)$values
  sumeigenval <- sum(eigenval)
  abs <- eigenval[1:2]/sumeigenval # variance explained by 2 eigenvectors
  ar[i] <- ar[i]+abs # daily variance explained, out of sample period
}

当我运行此程序时，我收到以下警告消息; ＆＃34;要替换的项目数不是替换长度的倍数＆＃34;，最后是由 n 相等数字组成的ar [i]向量。

我非常有信心这是计算2个特征向量的解释方差的正确方法

  ret <- Ret[start:end,]
  cov <- cov(ret)
  eigenval <- eigen(cov)$values
  sumeigenval <- sum(eigenval)
  abs <- eigenval[1:2]/sumeigenval

但我的问题是如何使用滚动窗口方法每天计算这个数字，正如Kritzman在他的文章中所做的那样。我的R知识并没有在这里削减，我很害怕，所以如果有人能在这方面帮助我，我将非常感激。如果不清楚，请随时提问。

Answer 1

我想我已经做到了。并非证明，但结果似乎合理。

我怀疑这是由于数据的形状所致。我也确信可以使它变得更快，更优雅，但是这里...

library(tidyverse)

# site <- 'http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/10_Industry_Portfolios_daily_TXT.zip'

# Import downloaded data
data <- read_table2(
  file = "10_Industry_Portfolios_Daily.txt", 
  col_types = cols(
    NoDur = col_date(format = "%Y%m%d")
    ), 
  skip = 9
  ) %>% 
  group_by(NoDur) %>% 
  slice(1) %>% 
  ungroup() %>% 
  filter(!is.na(NoDur)) %>% 
  mutate_if(.predicate = is.numeric, .funs = ~.x/100)

head(data)

# A tibble: 6 x 10
  NoDur         Durbl     Manuf   Enrgy    HiTec    Telcm   Shops     Hlth   Utils    Other
  <date>        <dbl>     <dbl>   <dbl>    <dbl>    <dbl>   <dbl>    <dbl>   <dbl>    <dbl>
1 1926-07-01  0.0002  -0.0028   -0.0023  0.00570 -0.0021  -0.0002 -0.0001   0.0097  0.00610
2 1926-07-02  0.00290  0.0107    0.0081  0.0064   0.0036   0.0026  0.0001   0.0013  0.00470
3 1926-07-06  0.00240  0.0072    0.0022  0.0017   0.00470  0.0017 -0.0023   0.0023  0.0073 
4 1926-07-07  0.0027   0.000600  0.0023 -0.0004  -0.001    0.0032 -0.00580  0.0033  0.0017 
5 1926-07-08  0.0069   0.0005    0.0015  0.00120  0.00350  0.004  -0.0036   0.0091 -0.002  
6 1926-07-09 -0.0039  -0.0115   -0.011  -0.016   -0.0073   0.0021  0.004   -0.0028 -0.0074

一旦您拥有正确形状的数据，就可以继续使用原始代码...

Ret <- data[,-1]

# lookback period in number of days (rolling window)
lb.period <- 500
nRow <- nrow(Ret)
nCol <- ncol(Ret)
n <- nRow-lb.period

ar <- rep(0,n) # reserve space for daily absorption ratio
for(i in 1:n) {
  # define rolling window
  start <- i
  end <- i+lb.period-1
  ret <- Ret[start:end,]
  cov <- cov(ret)
  eigenval <- eigen(cov)$values
  sumeigenval <- sum(eigenval)
  abs <- eigenval[1:2]/sumeigenval # variance explained by 2 eigenvectors
  ar[i] <- ar[i]+abs # daily variance explained, out of sample period
}

将其与数据一起产生以下内容...

ar_new <- c(rep(NA, lb.period), ar)
results <- bind_cols(data, Absorption = ar_new)
tail(results)

# A tibble: 6 x 11
  NoDur         Durbl    Manuf     Enrgy    HiTec    Telcm     Shops    Hlth   Utils    Other Absorption
  <date>        <dbl>    <dbl>     <dbl>    <dbl>    <dbl>     <dbl>   <dbl>   <dbl>    <dbl>      <dbl>
1 2019-06-21 -0.0027  -0.002   -0.00470   0.00610 -0.0026  -0.0069   -0.0034  0.002   0.00470      0.663
2 2019-06-24 -0.002   -0.00410  0.000600 -0.0092  -0.0005  -0.000600 -0.0045 -0.006  -0.0031       0.663
3 2019-06-25 -0.0027  -0.00350 -0.0045   -0.0078  -0.0184  -0.0068   -0.0065 -0.003  -0.0072       0.663
4 2019-06-26 -0.00940  0.0055  -0.0013    0.0174   0.0068  -0.0086    0.0017 -0.0125 -0.0178       0.663
5 2019-06-27  0.0026   0.0125   0.0028   -0.0083   0.00470  0.005     0.0053  0.0077  0.0017       0.662
6 2019-06-28  0.0036   0.00610  0.0095    0.0108   0.00350  0.0071    0.0016  0.0069  0.0075       0.661

...我们可以从中生成以下图表...

results %>% 
  ggplot(
    aes(
      x = NoDur, 
      y = Absorption
    )
  ) + 
  geom_line() + 
  theme_minimal() +
  labs(
    x = "", 
    y = "", 
    title = "Absorption Ratio over Time"
    )

R：PCA：计算每日解释的方差

1 个答案: