优化 R 中的代码以在 data.table 中进行向量比较

Question

作为我在 R 中的程序的一部分，我必须将大量的句子与一些函数进行比较（这里显示的一个是比较具有相同单词数的句子，以及是否只有一个不同的单词在这两句话之间）

为了让事情变得更快，我已经将所有单词转换为整数，所以我正在处理整数向量，所以示例函数是一个非常简单的函数

is_sub_num <- function(a,b){sum(!(a==b))==1}

其中 a,b 是字符向量，例如

a = c(1,2,3); b=c(1,4,3) 
is_sub_num(a,b)
# [1] TRUE

我的数据将存储在data.table

Classes ‘data.table’ and 'data.frame':  100 obs. of  2 variables:
 $ ID: int  1 2 3 4 5 6 7 8 9 10 ...
 $ V2:List of 100
  ..$ : int  4 4 3 4
  ..$ : int  1 2 3 1

每个条目的长度可能不同（在下面的示例中，条目的大小都是 4）

我有一个包含候选对 ID 的表，用于测试 DT 中的相应条目，上面的函数如下

is_pair_ok  <- function(pair){
            is_sub_num(DT[ID==pair[1],V2][[1]],DT[ID==pair[2],V2][[1]])}

这是我想要做的事情的简化：

set.seed=234
z = lapply(1:100, function(x) sample(1:4,size=4,replace=TRUE))
is_sub_num <- function(a,b){sum(!(a==b))==1}
is_pair_ok  <- function(pair){
        is_sub_num(DT[ID==pair[1],V2][[1]],DT[ID==pair[2],V2][[1]])}

pair_list <- as.data.table(cbind(sample(1:100,10000,replace=TRUE),sample(1:100,10000,replace=TRUE)))

DT <- as.data.table(1:100)
DT$V2 <- z
colnames(DT) <- c("ID","V2")

print(system.time(tmp <-apply(pair_list,1,is_pair_ok)))

这在我的笔记本电脑上大约需要 22 秒，尽管它只有 10,000 个条目并且功能非常基本。

你对如何加快代码速度有什么建议吗？？？

Answer 1

我已经深入研究了这个问题，这是我的答案。 我认为它很重要，每个人都应该知道，所以请为这篇文章投票，它不应该被差评！！

答案的代码如下。我添加了一些新参数以使问题更普遍。 关键是使用unlist函数。 每当我们将apply 用于list 对象时，我们会在R 中得到非常非常糟糕的性能。 爆炸对象和在向量中进行手动索引有点让人头疼，但速度提升是惊人的。

set.seed=234
N=100
nobs=10000
z = lapply(1:N, function(x) sample(1:4,size=sample(3:5),replace=TRUE))
is_sub_num <- function(a,b){sum(!(a==b))==1}
is_pair_ok  <- function(pair){
        is_sub_num(DT[ID==pair[1],V2][[1]],DT[ID==pair[2],V2][[1]])}

is_pair_ok1  <- function(pair){
        is_sub_num(zzz[pos_table[pair[1]]:(pos_table[pair[1]]+length_table[pair[1]] -1) ],
                   zzz[pos_table[pair[2]]:(pos_table[pair[2]]+length_table[pair[2]] -1) ]) }

pair_list <- as.data.table(cbind(sample(1:N,nobs,replace=TRUE),sample(1:N,nobs,replace=TRUE)))

DT <- as.data.table(1:N)
DT$V2 <- z
setnames(DT, c("ID","V2"))
setkey(DT, ID)

length_table <- sapply(z,length)
myfun <- function(i){sum(length_table[1:i])}
pos_table <- c(0,sapply(1:N,myfun))+1
zzz=unlist(z)

print(system.time(tmp_ref <- apply(pair_list,1,is_pair_ok)))
print(system.time(tmp <- apply(pair_list,1,is_pair_ok1)))
identical(tmp,tmp_ref)

这是输出

utilisateur     système      écoulé 
      20.96        0.00       20.96 
utilisateur     système      écoulé 
       0.70        0.00        0.71 
There were 50 or more warnings (use warnings() to see the first 50)
[1] TRUE

编辑 在这里发帖有点太长了。我试图从上面得出结论，并通过尝试加速并使用 unlist 和手动索引来修改我的程序的源代码。 新的实现实际上是更慢，这让我很惊讶，我不明白为什么......

Answer 2

现在我有 60% 的空闲时间：

library(data.table)
set.seed(234)

is_sub_num <- function(a,b) sum(!(a==b))==1
is_pair_ok2  <- function(p1, p2) is_sub_num(DT[p1,V2][[1]],DT[p2,V2][[1]]) 

DT <- as.data.table(1:100)
DT$V2 <- lapply(1:100, function(x) sample(1:4,size=4,replace=TRUE)) 
setnames(DT, c("ID","V2"))
setkey(DT, ID)

pair_list <- as.data.table(cbind(sample(1:100,10000,replace=TRUE),sample(1:100,10000,replace=TRUE)))
print(system.time(tmp <- mapply(FUN=is_pair_ok2, pair_list$V1, pair_list$V2)))

大部分效果是在is_pair_ok2()中为DT设置键并使用快速索引

再多一点（没有is_sub_num()这个函数）：

is_pair_ok3  <- function(p1, p2) sum(DT[p1,V2][[1]]!=DT[p2,V2][[1]])==1
print(system.time(tmp <- mapply(FUN=is_pair_ok3, pair_list$V1, pair_list$V2)))