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

有趣的问题。因此,循序渐进:

1. - stringdist 函数已矢量化:

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

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

但是给出两个具有相同长度的向量, 弦乐器演奏家 将导致在每个向量上并行循环(不会导致具有交叉结果的矩阵),如下 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 - 重写dismatrix函数,只使用一个loopy循环,并且只使用三角形部分(无 outer 那里,很慢!):

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

循环确实非常低效,这里有一个快速的例子表明:

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") 用comas替换所有空格,这会自动将距离分数加上+1(这是有意的吗?) 第二,您不必将第一个字母与其中有空格的字符串进行比较,因为这样只执行函数的第一部分。这是正确的,即使只有第一个被比较的单词包含空格,所以“你好”和“大提琴”的比较将被计算为比“你好”与“大提琴”更近的距离。

除此之外,您的代码似乎很容易矢量化,因为您使用的所有函数都已矢量化:stringlist()、grepl()、gsub()、substr()等。基本上,您对每个单词对执行3次计算:简单的“stringist()”、交换单词的stringlist()(如果第一个单词中有空格),以及第一个字母的简单比较,如果它们不同,则增加+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)
        })

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

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 

因此,上校的回答是最快的。

同样根据实际数据,我的和马克西姆的代码都崩溃了,只有上校的答案有效。 以下是结果

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

当我在实际数据上运行我的解决方案时-错误消息是-无法分配684MB的矢量 在运行马克西姆的解决方案时,R停止工作。