R 中随机变量的相关系数

Question

我的目标是获得一个新的相关变量（斯皮尔曼的）系数，其中每个数字对应于两个随机变量之间的相关性。

例如

var1=c(1, 2, 3, 0, 2)
var2=c(3, 6, 0, 1, 2)

我试过了

set.seed(1)
f1=numeric(10000)
for (i in 1:10000) {rand <- replicate(10000, sample(var1))
 rand1 <- replicate(10000, sample(var2))
 f1[i]=cor(rand, rand1, use ="everything", method=c("spearman"))
 } 

这给了我这个消息：警告消息：在 f1[i]=cor(rand, rand1, use = "everything", method = c("spearman")): 要替换的项目数不是替换长度的倍数

我试过这个：

cof <- cor((replicate(1000, sample(var1))), (replicate(1000, sample(var2))), use ="everything", method=c("spearman"))

它返回每个值的相关系数矩阵，而不是每个变量

或者，如果有一种方法可以让 R 将一个数据帧中的第 1 行与另一个数据帧中的第 1 行关联起来，然后到第 2 行，然后到第 3 行等，我可以得到我的随机变量的矩阵：

set.seed(1)
f1=numeric(10000)
for (i in 1:10000) {rand <- replicate(10000, sample(var1))
  rand1 <- replicate(10000, sample(var2))
  }

然后我必须相互关联

有没有办法在每对随机变量生成时计算它们之间的相关系数，然后为每个随机化创建一个由相关系数组成的新变量？

谢谢

Answer 1

我不完全确定我理解你试图做什么。 也许这会解决你的问题：

var1=c(1, 2, 3, 0, 2)
var2=c(3, 6, 0, 1, 2)

set.seed(1)
n=100
rand <- replicate(n, sample(var1))
rand1 <- replicate(n, sample(var2))

# That is maybe what you are searching for
f1 <- apply(rand,2,cor,rand1)

您将有一个n xn矩阵，其中每个( i, j )表示 rand 的第i列和 rand1 的第j列之间的相关性。

Answer 2

我认为你应该更容易只使用实际的斯皮尔曼相关公式，而不使用 cor()。

这看起来像这样：

spearman<-function(x,y){
  X<-as.matrix(x)
  Y<-as.matrix(y)
  y<-rowSums(X)
  a<-rowSums(Y)
  spearman<-2*cor(y,a)/(1+cor(y,a))
  return(spearman)
}

运行后，您可以使用

spearman(data1$firstrow,data2$secondrow)

计算所需的相关性。

然后我猜你可以使用这样的循环：

for (i in nrow(dat)) {
  for (i in nrow(dat)) {
  correlation<-spearman(datmat[i,],datmat2[i,])
  print(correlation[i])
  }
}

Answer 3

关于您的第二个问题，您的rand和rand1矩阵似乎有 5 行和许多列，并且您想将rand的每一列与rand1的等效列相关联？ 如果我猜对了，您可以使用cor.test来获取 spearman 等级相关性，例如在循环中。 由于这相对较慢，您还可以以矢量化形式重写 Spearman 等级相关性的公式并使用它（见下文）。 如果您对逐行相关感兴趣，则可以轻松调整或转置矩阵。

var1=c(1, 2, 3, 0, 2)
var2=c(3, 6, 0, 1, 2)
set.seed(1)
n=10000
rand <- replicate(n, sample(var1))
rand1 <- replicate(n, sample(var2))

library(matrixStats)
colwiseSpearman <- function(m1, m2, correct=TRUE){
    require(matrixStats)
    n <- dim(m1)[2]
    l <- dim(m1)[1]
    if (correct){
        Txy <- t(sapply(seq_len(n), function(x){
            t0 <- tabulate(rand[,x])
            t1 <- tabulate(rand1[,x])
            return(c(Tx=sum(t0^3-t0)/12, Ty=sum(t1^3-t1)/12))
        }))
        return(((l^3-l)/6 - rowSums((colRanks(rand, ties.method="average")-colRanks(rand1, ties.method="average"))^2) - Txy[,1] - Txy[,2])/sqrt(((l^3-l)/6 - 2*Txy[,1])*((l^3-l)/6 - 2*Txy[,2]))) # Spearman cor.coeff. corrected for ties 
    } else {
        return(1-(6*rowSums((colRanks(rand, ties.method="average")-colRanks(rand1, ties.method="average"))^2) / (l^3-l)))}
}

library(microbenchmark)
microbenchmark(a=colwiseSpearman(rand, rand1),
               b=as.numeric(sapply(seq_len(n), function(x) cor.test(rand[,x], rand1[,x], method="spearman")$estimate)), times=10L )
#> Unit: milliseconds
#>  expr        min         lq       mean    median         uq       max neval cld
#>     a   65.47719   68.06543   74.83393   69.2682   72.90266  109.9133    10  a 
#>     b 2769.97084 2789.39907 2826.01399 2821.6867 2849.08012 2880.5115    10   b
a <- colwiseSpearman(rand, rand1)
b <- as.numeric(sapply(seq_len(n), function(x) cor.test(rand[,x], rand1[,x], method="spearman")$estimate))
all.equal(a, b)
#> [1] TRUE

^{由reprex package (v0.3.0) 于 2020 年 5 月 3 日创建}