优化R代码以基于自定义距离函数创建距离矩阵

Question

优化R代码以基于自定义距离函数创建距离矩阵

rstringperformancelevenshtein-distanceedit-distance

6

我正在尝试基于自定义的距离函数为字符串创建距离矩阵(用于聚类)。我在一个包含6000个单词的列表上运行代码，但已经运行了90分钟，并且仍在运行。我的电脑配置是8GB RAM和Intel-i5，所以问题只能是出现在代码中。以下是我的代码:

library(stringdist)
#Calculate distance between two monograms/bigrams
stringdist2 <- function(word1, word2)
{
    #for bigrams - phrases with two words
    if (grepl(" ",word1)==TRUE) {
        #"Hello World" and "World Hello" are not so different for me
        d=min(stringdist(word1, word2),
        stringdist(word1, gsub(word2, 
                          pattern = "(.*) (.*)", 
                          repl="\\2,\\1")))
    }
    #for monograms(words)
    else{
        #add penalty of 5 points if first character is not same
        #brave and crave are more different than brave and bravery
        d=ifelse(substr(word1,1,1)==substr(word2,1,1),
                            stringdist(word1,word2),
                            stringdist(word1,word2)+5)
    }   
    d
}
#create distance matrix
stringdistmat2 = function(arr)
{
    mat = matrix(nrow = length(arr), ncol= length(arr))
    for (k in 1:(length(arr)-1))
    {
        for (j in k:(length(arr)-1))
        {           
            mat[j+1,k]  = stringdist2(arr[k],arr[j+1])      
        }
    }
    as.dist(mat)    
}

test = c("Hello World","World Hello", "Hello Word", "Cello Word")
mydmat = stringdistmat2(test)
> mydmat
  1 2 3
2 1    
3 1 2  
4 2 3 1

我认为问题可能是我使用了循环，而不是apply函数，但是我发现在许多情况下，循环并不那么低效。更重要的是，我没有足够的技能来将我的循环改写为嵌套的apply函数，例如k in 1:n和j in k:n。我想知道是否还有其他可以进行优化的方法。

- Gaurav Singhal

在这里等待和在R屏幕上看起来不太对，所以我打开了另一个R控制台并尝试了以下内容：

arr1 = c("Hello World","World Hello", "Hello Word", "Cello Word")   mytest = function(arr1){as.dist(sapply(arr1,stringdist,b=arr1))}   mytest(arr1)

它给了我想要的距离矩阵。现在我想知道如何更改我的函数，使其适用于向量。 - Gaurav Singhal

3个回答

3

循环确实非常低效，这里有一个快速的示例来证明这一点：

x=rnorm(1000000)
system.time({y1=sum(x)})
system.time({
        y2=0
        for(i in 1:length(x)){
                y2=y2+x[i]
        }
})

这是对内部向量化函数sum()的简单比较，该函数在内部循环中计算所有元素的总和；第二个函数使用R代码执行相同的操作，这使得它反复调用另一个内部函数+，效率不高。

首先，在您定义的函数中有一些错误/不一致之处。这部分： gsub(word2, pattern = "(.*) (.*)", repl="\\2,\\1") 将所有空格替换为逗号，这会自动将距离得分加1（是否有意？）其次，您没有比较具有空格的字符串的第一个字母，因为只有函数的第一部分被执行。即使只有要比较的单词的第一个部分包含空格，这也是正确的，因此“Hello”和“Cello”的比较会被计算为比“Hello”和“Cello”更接近距离。

除此之外，您的代码似乎很容易向量化，因为您使用的所有函数都已经向量化：stringdist()、grepl()、gsub()、substr()等等。基本上，每个单词对需要执行3个计算：简单的'stringdist()'、交换单词的'stringdist()'（如果第一个单词中有空格），以及仅比较第一个字母并添加+5分（如果它们不同）。

这是以向量化方式复制您的函数的代码，它在计算300x300矩阵时提供了约50倍的速度提升：

stringdist3<-function(words1,words2){
m1<-stringdist(words1,words2)
m2<-stringdist(words1,gsub(words2, 
                           pattern = "(.*) (.*)", 
                           repl="\\2,\\1"))
m=mapply(function(x,y) min(x,y),m1,m2)

m3<-5*(substr(words1,1,1)!=substr(words2,1,1) & !grepl(" ",words1))

m3+m
}
stringdistmat3 = function(arr){
        outer(arr,arr,function(x,y) stringdist3(x,y))
}
test = c("Hello World","World Hello", "Hello Word", "Cello Word")
arr=sample(test,size=300,replace=TRUE)
system.time({mat = stringdistmat2(arr)})
system.time({
        mat2=stringdistmat3(arr)
        })

- Maksim Gayduk

哈，我有一个类似的答案，但我认为它会更快一些；不管怎样，很好的帖子，点赞。 - Colonel Beauvel

感谢您的回答，指出了我的错误，并教我如何提高循环效率。逗号而非空格是一个笔误，我需要为bigrams制作更好的版本。我会尝试您的版本并告诉您结果。我也正在创建自己的向量化版本，并将与您的进行比较。 - Gaurav Singhal

3

你的循环演示运行缓慢的主要原因实际上是因为对象增长时没有预先分配内存，而不是因为循环本身。例如，data.table在将for循环与set函数组合使用时能够获得出色的性能表现。 - David Arenburg

@Maksim，你的解决方案在测试数据上更快，但是当我在实际数据上运行它时，它会导致R崩溃。我认为如果我关闭一切，它可能会成功运行，但是由于Colonel的解决方案在实际数据上运行良好且在测试数据上更快，所以我会选择他的方案。感谢你的所有帮助。 - Gaurav Singhal

0

我也试图创造一种替代方法来改进我的答案。基本上，我删除了创建距离函数并直接创建了距离矩阵。这是我想到的。我知道这个解决方案可以改进。所以欢迎任何建议。

strdistmat2 <- function(v1,v2,type="m"){
    #for monograms
    if (type=="m")  {
        penalty = sapply(substr(v1,1,1),stringdist,b=substr(v2,1,1)) * 5
        d = sum(sapply(v1,stringdist,b=v2),penalty)
    }
    #for bigrams
    else if(type=="b")  {       
        d1 = sapply(v1,stringdist,b=v2) 
        d2 = sapply(v1,stringdist,b=gsub(v2,pattern = "(.*) (.*)", repl="\\2 \\1"))
        d = pmin(d1,d2)
    }
    d
}

我已经比较了下面各种解决方案的时间。

> test = c("Hello World","World Hello", "Hello Word", "Cello Word")
> arr=sample(test,size=6000,replace=TRUE)
> system.time({mat=strdistmat2(arr,arr,"b")})
   user  system elapsed 
  96.89    1.63   70.36 
> system.time({mat2=stringdistmat3(arr)})
   user  system elapsed 
 469.40    5.69  439.96 
> system.time({mat3=stringdistmatFast(arr)})
   user  system elapsed 
  57.34    0.72   41.22

因此 - Colonel的答案是最快的。

在实际数据上，我的代码和Maksim的代码都崩溃了，只有Colonel的答案有效。以下是结果

> system.time({mat3=stringdistmatFast(words)})
   user  system elapsed 
 314.63    1.78  291.94

当我在实际数据上运行我的解决方案时，出现了错误消息 - 无法分配 684 MB 的向量，而在运行 Maksim 的解决方案时，R 停止工作。

- Gaurav Singhal

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Colonel Beauvel · Accepted Answer

有趣的问题。所以逐步进行：

1- stringdist函数已经向量化：

#> stringdist("byye", c('bzyte','byte'))
#[1] 2 1

#> stringdist(c('doggy','gadgy'), 'dodgy')
#[1] 1 2

但是如果给出两个长度相等的向量，stringdist 将会并行地循环遍历每个向量（不会得到一个包含交叉结果的矩阵），就像 Map 一样：

#> stringdist(c("byye","alllla"), c('bzyte','byte'))
#[1] 2 6

2 - 重写你的函数，使你的新函数保留这个向量化特性：

stringdistFast <- function(word1, word2)
{
    d1 = stringdist(word1, word2)
    d2 = stringdist(word1, gsub("(.+) (.+)", "\\2 \\1", word2))

    ifelse(d1==d2,d1+5*(substr(d1,1,1)!=substr(d2,1,1)),pmin(d1,d2))
}

确实，它的工作方式是相同的：

#> stringdistFast("byye", c('bzyte','byte'))
#[1] 2 1

#> stringdistFast("by ye", c('bzyte','byte','ye by'))
#[1] 3 2 0

3 - 使用仅有一个循环和仅在三角形部分（不使用outer，它会使速度变慢！）的方式重写dismatrix函数：

stringdistmatFast <- function(test)
{
    m = diag(0, length(test))
    sapply(1:(length(test)-1), function(i)
    {
        m[,i] <<- c(rep(0,i), stringdistFast(test[i],test[(i+1):length(test)]))
    }) 

    `dimnames<-`(m + t(m), list(test,test))
}

4 - 使用该函数：

#> stringdistmatFast(test)
#            Hello World World Hello Hello Word Cello Word
#Hello World           0           0          1          2
#World Hello           0           0          1          2
#Hello Word            1           1          0          1
#Cello Word            2           2          1          0