R 创建特定带状矩阵的更有效方法

我使用以下代码：

var <- c(rep(4,4),rep(9,5))
cov <- diag(var)
n <- length(var)
rho <- 0.2 
for(i in 1:(n-1)){
   for(j in (i+1):n){
    if (j <= i + 4) cov[i,j] <- rho/(j-i)* sqrt(var[i] * var[j])
   }
}

---

但是，这段代码太慢，无法计算大n的情况。你有什么有效的解决方案吗？

我假设你的

n

很大，所以你需要一个带宽为5的稀疏带状矩阵

首先是像

diff

这样的辅助函数，它允许使用任意函数而不仅仅是减法（

-

）

输出：

9 x 9 sparse Matrix of class "dgCMatrix"

 [1,] 4 0.8 0.4 0.2666667 0.3 .   .   .   .   
 [2,] . 4.0 0.8 0.4000000 0.4 0.3 .   .   .   
 [3,] . .   4.0 0.8000000 0.6 0.4 0.3 .   .   
 [4,] . .   .   4.0000000 1.2 0.6 0.4 0.3 .   
 [5,] . .   .   .         9.0 1.8 0.9 0.6 0.45
 [6,] . .   .   .         .   9.0 1.8 0.9 0.60
 [7,] . .   .   .         .   .   9.0 1.8 0.90
 [8,] . .   .   .         .   .   .   9.0 1.80
 [9,] . .   .   .         .   .   .   .   9.00

---

无论使用什么，都需要填充矩阵的上/下三角形。在这种情况下，模式非常简单，即

mat1
fdiff <- function(x,lag,f) {
  i1 <- -seq_len(lag)
  f(x[i1],x[-length(x):-(length(x)-lag+1L)]) 
}

gm <- function(x,y) sqrt(x*y)

x <- c(rep(4,4),rep(9,5))
0.2*fdiff(x,1,gm)/1
# [1] 0.8 0.8 0.8 1.2 1.8 1.8 1.8 1.8

library(Matrix)
x <- c(rep(4,4),rep(9,5))
bandSparse(n,k=0:4,diagonals=
  c(list(x),lapply(1:4,function(lag) 0.2*fdiff(x,lag,gm)/lag)))

9 x 9 sparse Matrix of class "dgCMatrix"

 [1,] 4 0.8 0.4 0.2666667 0.3 .   .   .   .   
 [2,] . 4.0 0.8 0.4000000 0.4 0.3 .   .   .   
 [3,] . .   4.0 0.8000000 0.6 0.4 0.3 .   .   
 [4,] . .   .   4.0000000 1.2 0.6 0.4 0.3 .   
 [5,] . .   .   .         9.0 1.8 0.9 0.6 0.45
 [6,] . .   .   .         .   9.0 1.8 0.9 0.60
 [7,] . .   .   .         .   .   9.0 1.8 0.90
 [8,] . .   .   .         .   .   .   9.0 1.80
 [9,] . .   .   .         .   .   .   .   9.00

library(inline)
include="
#include <math.h>
#include <vector>
"

body="
NumericMatrix x(X);
int nrow = x.nrow();
int ncol = x.ncol();
std::vector<double> diag(nrow);
for (int i=0;i<nrow;i++){
    diag[i] = sqrt(x(i,i));
}
double rho = .2;
for(int j=1;j<ncol;j++){
       for(int i=0; i<(j-1);i++){
               if (j < i + nrow-4){// Change to your version
                  x(i,j) = rho/double(j-i)*diag[i]*diag[j];
                  x(j,i) = x(i,j);
}
   }
}
return(x);
"
f1 <- cxxfunction(signature(X='matrix'),body,plugin='Rcpp',include=include)

> dim(C)
[1] 3000 3000
> system.time(f1(C))
   user  system elapsed 
  0.086   0.000   0.087