In R distance between two sentence: Word-level comparison by minimum edit distance答案

【问题标题】：In R distance between two sentences: Word-level comparison by minimum edit distanceIn R distance between two sentence: Word-level comparison by minimum edit distance
【发布时间】：2019-02-12 14:27:57
【问题描述】：

在尝试学习 R 时，我想在 R 中实现以下算法。请考虑以下两个列表：

List 1: "crashed", "red", "car"
List 2: "crashed", "blue", "bus"

我想知道将“list1”转换为“list2”需要多少操作。如您所见，我只需要两个操作： 1. Replace "red" with "blue". 2. Replace "car" with "bus".

但是，我们如何才能自动找到这样的操作数量。我们可以有几个动作来转换句子：添加、删除或替换列表中的单词。现在，我将尽力解释算法应该如何工作：

第一步：我将创建一个这样的表：

行：i= 0,1,2,3，列：j = 0,1,2,3

(example: value[0,0] = 0 , value[0, 1] = 1 ...)

                 crashed    red     car
         0          1        2       3

crashed  1
blue     2
bus      3

现在，我将尝试填满表格。请注意，表格中的每个单元格都显示了我们需要执行的重新格式化句子的操作数（添加、删除或替换）。考虑 "crashed" 和 "crashed" (value[1,1]) 之间的交互，显然我们不需要更改它，因此 值将是 '0'。 因为它们是同一个词。基本上，我们得到了对角线值 = value[0,0]

                 crashed    red     car
         0          1        2       3

crashed  1          0
blue     2
bus      3

现在，考虑“crashed”和句子的第二部分“red”。由于它们不是同一个词，我们可以使用这样计算更改的数量：

min{value[0,1] , value[0,2] and value[1,1]} + 1 
min{ 1, 2, 0} + 1 = 1

因此，我们只需删除“红色”即可。因此，表格将如下所示：

                 crashed    red     car
         0          1        2       3

crashed  1          0        1
blue     2  
bus      3

我们将继续这样： “坠毁”和“汽车”将是：

min{value[0,3], value[0,2] and value[1,2]} + 1 
min{3, 2, 1} +1 = 2

表格将是：

                 crashed    red     car
         0          1        2       3

crashed  1          0        1       2
blue     2  
bus      3

我们将继续这样做。最终结果将是：

             crashed    red     car
         0      1        2       3

crashed  1      0        1       2
blue     2      1        1       2
bus      3      2        2       2

如您所见，表格中的最后一个数字表示两个句子之间的距离：value[3,3] = 2

基本上，算法应该是这样的：

 if (characters_in_header_of_matrix[i]==characters_in_column_of_matrix [j] & 
                                            value[i,j] == value[i+1][j-1] )

then {get the 'DIAGONAL VALUE' #diagonal value= value[i, j-1]}

else{
value[i,j] = min(value[i-1, j], value[i-1, j-1],  value[i, j-1]) + 1
 }
  endif

为了找到您可以在矩阵的标题和列中看到的两个列表的元素之间的差异，我使用了strcmp() 函数，它会在比较时给我们一个布尔值（TRUE 或 FALSE）字。但是，我未能实现这一点。非常感谢您在这方面的帮助，谢谢。

【问题讨论】：

感谢您提供更好的描述。到目前为止，这更容易理解。我将在几分钟内发布回复。 :-)
@Oliver 我试图澄清：-P。清楚不是我的闪光点，我会检查你的答案，但乍一看，它看起来很棒。谢谢。
很高兴我能帮上忙。希望如果有人知道更好的答案，他们会提供。任何问题都可以在我的回答中作为评论提出。 :-)

标签： r dataframe matrix nlp edit-distance

【解决方案1】：

问题

在上一篇文章中进行了一些澄清之后，并且在帖子更新之后，我的理解是零在问：'如何迭代地计算两个字符串中单词差异的数量'。

我不知道 R 中的任何实现，但如果我不存在我会感到惊讶。我花了一点时间来创建一个简单的实现，为了简单起见稍微改变了算法（对于不感兴趣的人，向下滚动查看 2 个实现，1 个在纯 R 中，一个使用最少的 Rcpp）。实现的总体思路：

用长度为n_1和n_2的string_1和string_2初始化
计算第一个min(n_1, n_2)元素之间的累积差异，
将此累积差异用作矩阵中的对角线
将第一个非对角元素设置为第一个元素 + 1
计算剩余的非对角元素为：diag(i) - diag(i-1) + full_matrix(i-1,j)
在上一步中，i 迭代对角线，j 迭代行/列（任何一个都有效），我们从第三个对角线开始，因为第一个 2x2 矩阵在步骤 1 到 4 中填充
将剩余的abs(n_1 - n_2) 元素计算为full_matrix[,min(n_1 - n_2)] + 1:abs(n_1 - n_2)，将后者应用于先前的每个值，并将它们适当地绑定到full_matrix。

输出是一个矩阵，其中包含相应字符串的维度行和列名称，已对其进行了格式化以便于阅读。

在 R 中的实现

Dist_between_strings <- function(x, y, 
                                 split = " ", 
                                 split_x = split, split_y = split, 
                                 case_sensitive = TRUE){
  #Safety checks
  if(!is.character(x) || !is.character(y) || 
     nchar(x) == 0 || nchar(y) == 0)
    stop("x, y needs to be none empty character strings.")
  if(length(x) != 1 || length(y) != 1)
    stop("Currency the function is not vectorized, please provide the strings individually or use lapply.")
  if(!is.logical(case_sensitive))
    stop("case_sensitivity needs to be logical")
  #Extract variable names of our variables
  # used for the dimension names later on
  x_name <- deparse(substitute(x))
  y_name <- deparse(substitute(y))
  #Expression which when evaluated will name our output
  dimname_expression <- 
    parse(text = paste0("dimnames(output) <- list(",make.names(x_name, unique = TRUE)," = x_names,",
                        make.names(y_name, unique = TRUE)," = y_names)"))
  #split the strings into words
  x_names <- str_split(x, split_x, simplify = TRUE)
  y_names <- str_split(y, split_y, simplify = TRUE)
  #are we case_sensitive?
  if(isTRUE(case_sensitive)){
    x_split <- str_split(tolower(x), split_x, simplify = TRUE)
    y_split <- str_split(tolower(y), split_y, simplify = TRUE)
  }else{
    x_split <- x_names
    y_split <- y_names
  }
  #Create an index in case the two are of different length
  idx <- seq(1, (n_min <- min((nx <- length(x_split)),
                              (ny <- length(y_split)))))
  n_max <- max(nx, ny)
  #If we have one string that has length 1, the output is simplified
  if(n_min == 1){ 
    distances <- seq(1, n_max) - (x_split[idx] == y_split[idx])
    output <- matrix(distances, nrow = nx)
    eval(dimname_expression)
    return(output)
  }
  #If not we will have to do a bit of work
  output <- diag(cumsum(ifelse(x_split[idx] == y_split[idx], 0, 1)))
  #The loop will fill in the off_diagonal
  output[2, 1] <- output[1, 2] <- output[1, 1] + 1 
  if(n_max > 2)
    for(i in 3:n_min){
      for(j in 1:(i - 1)){
        output[i,j] <- output[j,i] <- output[i,i] - output[i - 1, i - 1] + #are the words different?
          output[i - 1, j] #How many words were different before?
      }
    }
  #comparison if the list is not of the same size
  if(nx != ny){
    #Add the remaining words to the side that does not contain this
    additional_words <- seq(1, n_max - n_min)
    additional_words <- sapply(additional_words, function(x) x + output[,n_min])
    #merge the additional words
    if(nx > ny)
      output <- rbind(output, t(additional_words))
    else
      output <- cbind(output, additional_words)
  }
  #set the dimension names, 
  # I would like the original variable names to be displayed, as such i create an expression and evaluate it
  eval(dimname_expression)
  output
}

请注意，该实现不是矢量化的，因此只能接受单个字符串输入！

测试实现

为了测试实现，可以使用给定的字符串。因为据说它们包含在列表中，所以我们必须将它们转换为字符串。请注意，该函数允许以不同的方式拆分每个字符串，但它假定使用空格分隔的字符串。所以首先我将展示如何实现到正确格式的转换：

list_1 <- list("crashed","red","car")
list_2 <- list("crashed","blue","bus")
string_1 <- paste(list_1,collapse = " ")
string_2 <- paste(list_2,collapse = " ")
Dist_between_strings(string_1, string_2)

输出

#Strings in the given example
         string_2
string_1  crashed blue bus
  crashed       0    1   2
  red           1    1   2
  car           2    2   2

这不完全是输出，但它产生了相同的信息，因为单词是按照字符串中给出的顺序排列的。 更多示例 现在我说它也适用于其他字符串，这确实是事实，所以让我们尝试一些随机的用户制作的字符串：

#More complicated strings
string_3 <- "I am not a blue whale"
string_4 <- "I am a cat"
string_5 <- "I am a beautiful flower power girl with monster wings"
string_6 <- "Hello"
Dist_between_strings(string_3, string_4, case_sensitive = TRUE)
Dist_between_strings(string_3, string_5, case_sensitive = TRUE)
Dist_between_strings(string_4, string_5, case_sensitive = TRUE)
Dist_between_strings(string_6, string_5)

运行这些表明这些确实产生了正确的答案。请注意，如果任一字符串的大小为 1，则比较会快很多。

对实现进行基准测试

现在该实现已被接受，因为正确，我们想知道它的性能如何（对于不感兴趣的读者，可以滚动浏览本节，查看提供更快实现的地方）。为此，我将使用更大的字符串。对于完整的基准测试，我应该测试各种字符串大小，但出于此目的，我将只使用 2 个相当大的字符串，大小分别为 1000 和 2500。为此，我使用 R 中的 microbenchmark 包，其中包含 microbenchmark 函数，它声称精确到纳秒。函数本身执行代码 100 次（或用户定义的）次数，返回运行时间的平均值和四分位数。由于 R 的其他部分（例如垃圾清理器），中值通常被认为是对函数实际平均运行时间的良好估计。执行及结果如下图：

#Benchmarks for larger strings
set.seed(1)
string_7 <- paste(sample(LETTERS,1000,replace = TRUE), collapse = " ")
string_8 <- paste(sample(LETTERS,2500,replace = TRUE), collapse = " ")
microbenchmark::microbenchmark(String_Comparison = Dist_between_strings(string_7, string_8, case_sensitive = FALSE))
# Unit: milliseconds
# expr                   min      lq      mean   median       uq      max neval
# String_Comparison 716.5703 729.4458 816.1161 763.5452 888.1231 1106.959   100

分析

现在我发现运行时间非常慢。实施的一个用例可能是对学生提交的初步检查以检查抄袭，在这种情况下，低差异计数很可能表明抄袭。这些可能很长，可能有数百个handins，因此我希望运行速度非常快。为了弄清楚如何改进我的实现，我使用了 profvis 包和对应的 profvis 函数。为了分析我在另一个 R 脚本中导出的函数，在分析之前运行代码 1 一次以编译代码并避免分析噪音（重要）。运行分析的代码如下所示，输出中最重要的部分显示在其下方的图像中。

library(profvis)
profvis(Dist_between_strings(string_7, string_8, case_sensitive = FALSE))

现在，尽管有颜色，但在这里我可以看到一个明显的问题。到目前为止，填充非对角线的循环负责大部分运行时间。 R（如 python 和其他未编译的语言）循环非常慢。

使用 Rcpp 提高性能

为了改进实现，我们可以使用Rcpp 包在c++ 中实现循环。这是相当简单的。如果我们避免使用迭代器，该代码与我们在 R 中使用的代码没有什么不同。可以在文件 -> 新文件 -> c++ 文件中制作 c++ 脚本。以下 c++ 代码将被粘贴到相应的文件中，并使用源按钮获取源代码。

//Rcpp Code
#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
NumericMatrix Cpp_String_difference_outer_diag(NumericMatrix output){
  long nrow = output.nrow();
  for(long i = 2; i < nrow; i++){ // note the 
    for(long j = 0; j < i; j++){
      output(i, j) = output(i, i) - output(i - 1, i - 1) + //are the words different?
                                  output(i - 1, j);
      output(j, i) = output(i, j);
    }
  }
  return output;
}

需要更改相应的 R 函数以使用此函数而不是循环。代码和第一个函数类似，只是切换循环调用c++函数。

Dist_between_strings_cpp <- function(x, y, 
                                 split = " ", 
                                 split_x = split, split_y = split, 
                                 case_sensitive = TRUE){
  #Safety checks
  if(!is.character(x) || !is.character(y) || 
     nchar(x) == 0 || nchar(y) == 0)
    stop("x, y needs to be none empty character strings.")
  if(length(x) != 1 || length(y) != 1)
    stop("Currency the function is not vectorized, please provide the strings individually or use lapply.")
  if(!is.logical(case_sensitive))
    stop("case_sensitivity needs to be logical")
  #Extract variable names of our variables
  # used for the dimension names later on
  x_name <- deparse(substitute(x))
  y_name <- deparse(substitute(y))
  #Expression which when evaluated will name our output
  dimname_expression <- 
    parse(text = paste0("dimnames(output) <- list(", make.names(x_name, unique = TRUE)," = x_names,",
                        make.names(y_name, unique = TRUE)," = y_names)"))
  #split the strings into words
  x_names <- str_split(x, split_x, simplify = TRUE)
  y_names <- str_split(y, split_y, simplify = TRUE)
  #are we case_sensitive?
  if(isTRUE(case_sensitive)){
    x_split <- str_split(tolower(x), split_x, simplify = TRUE)
    y_split <- str_split(tolower(y), split_y, simplify = TRUE)
  }else{
    x_split <- x_names
    y_split <- y_names
  }
  #Create an index in case the two are of different length
  idx <- seq(1, (n_min <- min((nx <- length(x_split)),
                              (ny <- length(y_split)))))
  n_max <- max(nx, ny)
  #If we have one string that has length 1, the output is simplified
  if(n_min == 1){ 
    distances <- seq(1, n_max) - (x_split[idx] == y_split[idx])
    output <- matrix(distances, nrow = nx)
    eval(dimname_expression)
    return(output)
  }
  #If not we will have to do a bit of work
  output <- diag(cumsum(ifelse(x_split[idx] == y_split[idx], 0, 1)))
  #The loop will fill in the off_diagonal
  output[2, 1] <- output[1, 2] <- output[1, 1] + 1 
  if(n_max > 2) 
    output <- Cpp_String_difference_outer_diag(output) #Execute the c++ code
  #comparison if the list is not of the same size
  if(nx != ny){
    #Add the remaining words to the side that does not contain this
    additional_words <- seq(1, n_max - n_min)
    additional_words <- sapply(additional_words, function(x) x + output[,n_min])
    #merge the additional words
    if(nx > ny)
      output <- rbind(output, t(additional_words))
    else
      output <- cbind(output, additional_words)
  }
  #set the dimension names, 
  # I would like the original variable names to be displayed, as such i create an expression and evaluate it
  eval(dimname_expression)
  output
}

测试 c++ 实现

为了确保实现是正确的，我们检查 c++ 实现是否获得相同的输出。

#Test the cpp implementation
identical(Dist_between_strings(string_3, string_4, case_sensitive = TRUE),
          Dist_between_strings_cpp(string_3, string_4, case_sensitive = TRUE))
#TRUE

最终基准测试

现在这实际上更快吗？为了看到这一点，我们可以使用microbenchmark 包运行另一个基准测试。代码和结果如下所示：

#Final microbenchmarking
microbenchmark::microbenchmark(R = Dist_between_strings(string_7, string_8, case_sensitive = FALSE),
                               Rcpp = Dist_between_strings_cpp(string_7, string_8, case_sensitive = FALSE))
# Unit: milliseconds
# expr       min       lq      mean    median        uq       max neval
# R    721.71899 753.6992 850.21045 787.26555 907.06919 1756.7574   100
# Rcpp  23.90164  32.9145  54.37215  37.28216  47.88256  243.6572   100

从大约21 ( = 787 / 37) 的微基准中值改进因子来看，这与仅实现单个循环相比是一个巨大的改进！

【讨论】：

我知道你已经很久没有回答这个问题了，但我有一个后续问题：我正在尝试在 for loop 中使用 Dist-between_strings()。目标是在字符串列表上使用该函数，但它不起作用；但是，它在列表的每个实体上都非常有效。您对这个潜在问题有任何线索吗？
我不能确定，但很可能是索引错误。这些函数只允许单个字符串作为输入。假设您想比较两个字符串向量，进行成对比较（比较每个向量中的第一个元素，比较第二个元素......等等），您可以使用n <- length(vector_string1); output <- vector("list", n); for( i in seq(n)); output[i] <- Dist_between_strings_cpp(vector_strign1[i], vector_string2[i])。
如果相反，您希望将每个元素与另一个向量中的每个元素进行比较，您可以首先使用 expand.grid 创建每个字符串组合，然后遍历这些组合：@987654352 @
未经测试的示例数据：vector_string1 <- c("hello kitty is green","kitty cat is gray","cat holds farts"); vector_string2 <- c("my lovely kitty is green","kitty cat is blue","gray cat farts")
那个错误信息起到了作用，而且修复非常简单（他说，经过一个小时的搜索，然后在data.frame的源代码中偶然发现它。）简单的@如果 987654355@ 和 y_name 包含子集，则它们与 R 的命名约定不兼容。但！ R 的make.names 函数可以解决这个问题。将维度命名部分更改为dimname_expression <- parse(text = paste0("dimnames(output) <- list(", make.names(x_name, unique = TRUE), " = x_names,",make.names(x_name, unique = TRUE), " = y_names)"))。我已经编辑了我的帖子，以反映这一点（可能尚未更新）

【解决方案2】：

R 中已经有一个我们可以利用的编辑距离功能：adist()。

由于它适用于字符级别，我们必须为句子中的每个唯一单词分配一个字符，并将它们拼接在一起形成伪单词，我们可以计算它们之间的距离。

s1 <- c("crashed", "red", "car")
s2 <- c("crashed", "blue", "bus")

ll <- list(s1, s2)

alnum <- c(letters, LETTERS, 0:9)

ll2 <- relist(alnum[factor(unlist(ll))], ll)

ll2 <- sapply(ll2, paste, collapse="")

adist(ll2)
#      [,1] [,2]
# [1,]    0    2
# [2,]    2    0

据我所知，这里的主要限制是可用的唯一字符数，在本例中为 62，但可以很容易地扩展，具体取决于您的语言环境。例如：intToUtf8(c(32:126, 161:300), TRUE).

【讨论】：

这似乎不符合问题中的实际描述。零似乎要求迭代词距离，并且 adist 计算字符更改的数量以为向量中的每一对返回相同的字符串。可能存在另一种实现，但在我下面的回答中，也可以使用特定问题的实现。
@AkselA 我已经尝试过 adist() 函数，如您所见，它没有给出我正在寻找的值。它比较字符的变化。无论如何，谢谢你的帮助。
@Zero: adist() 不会给出部分距离，但adist() 输出中的2 与比较矩阵末尾的2 相同。奥利弗的答案要完整得多，但adist() 仍然是部分解决方案，我认为这是一个有效的答案。