R:将循环转换为矢量化执行，以实现行之间的相关性

Question

我希望以逐行方式基于dt1中的值有条件地从dt2中选择值，然后成对地关联dt2中的行，并将相关值保存在新矩阵dt3中。在我开始用文字解释之前，我想R代码更具描述性。我通过在数据帧上循环来实现这一点，这相当慢。我相信有可能以矢量化的方式来提高性能。有人提出解决方案或建议吗？非常感谢！

library(data.table)
dt1 <- data.table(a=round(runif(100)), b=round(runif(100)), c=round(runif(100)), d=round(runif(100)), e=round(runif(100)), f=round(runif(100)))
dt2 <- data.table(a=runif(100), b=runif(100), c=runif(100), d=runif(100), e=runif(100), f=runif(100))
m <- nrow(dt2)
n <- m
dt3 <- matrix(nrow=m, ncol=n)
col_vec <- 1:n
for (r in 1:m) {
for (p in col_vec) {
selection <- dt1[r,] > 0 & dt1[p,] > 0 
selection <- as.vector(selection)
r_values <- as.numeric(dt2[p, ..selection])
p_values <- as.numeric(dt2[r, ..selection])
correlation_value <- cor(r_values, p_values, method='spearman', use='na.or.complete')
dt3[r,p] <- correlation_value
dt3[p,r] <- correlation_value

print(glue('row {r} vs row {p}'))
}
col_vec <- col_vec[-1]
}

Answer 1

您可以将内置的NA排除机制与use = "pairwise.complete.obs"一起使用。

将dt2中的值设置为缺失如果对应的dt1值是0，则使用一个cor()调用。

library(data.table)
n <- 4
set.seed(42)
dt1 <- data.table(a = round(runif(n)), b = round(runif(n)), c = round(runif(n)), d = round(runif(n)), e = round(runif(n)), f = round(runif(n)))
dt2 <- data.table(a = runif(n), b = runif(n), c = runif(n), d = runif(n), e = runif(n), f = runif(n))
replace(t(dt2), t(dt1) == 0, NA) |>
cor(method = "spearman", use = "pairwise.complete.obs")
#>      [,1] [,2] [,3] [,4]
#> [1,]  1.0    1   -1  0.1
#> [2,]  1.0    1   NA -1.0
#> [3,] -1.0   NA    1   NA
#> [4,]  0.1   -1   NA  1.0

基准测试功能中的两种方法：

f_loop <- function(dt1, dt2) {
m <- nrow(dt2)
n <- m
dt3 <- matrix(nrow = m, ncol = n)
col_vec <- 1:n
for (r in 1:m) {
for (p in col_vec) {
selection <- dt1[r, ] > 0 & dt1[p, ] > 0
selection <- as.vector(selection)

r_values <- as.numeric(dt2[p, ..selection])
p_values <- as.numeric(dt2[r, ..selection])

correlation_value <- cor(r_values, p_values, method = "spearman", use = "na.or.complete")
dt3[r, p] <- correlation_value
dt3[p, r] <- correlation_value
# print(glue::glue("row {r} vs row {p}"))
}
col_vec <- col_vec[-1]
}
dt3
}
f_repl <- function(dt1, dt2) {
replace(t(dt2), t(dt1) == 0, NA) |>
cor(method = "spearman", use = "pairwise.complete.obs")
}

使用更大的数据进行测试：

n <- 100
set.seed(42)
dt1 <- data.table(a = round(runif(n)), b = round(runif(n)), c = round(runif(n)), d = round(runif(n)), e = round(runif(n)), f = round(runif(n)))
dt2 <- data.table(a = runif(n), b = runif(n), c = runif(n), d = runif(n), e = runif(n), f = runif(n))
# Check that we get the same result
all.equal(f_loop(dt1, dt2), f_repl(dt1, dt2))
#> [1] TRUE
bench::system_time(f_loop(dt1, dt2))
#> process    real 
#>   5.86s   5.92s
bench::system_time(f_repl(dt1, dt2))
#> process    real 
#>   188ms   198ms