在R中两个句子之间的距离：通过最小编辑距离进行词级比较

Question

在尝试学习 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）。但是，我未能实现这一点。我非常感谢你在这方面的帮助，谢谢。

Answer 1

问题

经过上一篇文章的一些澄清以及该文章的更新后，我的理解是零在问：“如何迭代地计算两个字符串中单词差异的数量”。

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

1. 初始化为string_1和string_2长度为n_1和n_2
2. 计算第一个元素之间的累积差异min(n_1, n_2)，
3. 使用这个累积差值作为矩阵中的对角线
4. 将第一个非对角元素设置为第一个元素 + 1
5. 计算剩余的非对角元素：diag(i) - diag(i-1) + full_matrix(i-1,j)
6. 在上一步中，i 迭代对角线，j 迭代行/列（任一行/列都有效），我们从第三个对角线开始，因为第一个 2x2 矩阵在步骤 1 到 4 中填充
7. 将剩余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 的相当大的字符串。为此，我使用microbenchmarkR 中的包，其中包含一个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

分析

现在我发现运行时间非常慢。实施的一个用例可能是对学生提交的材料进行初步检查，以检查是否抄袭，在这种情况下，较低的差异计数很可能表明存在抄袭。这些可能会很长，并且可能有数百次交接，因此我希望运行速度非常快。为了弄清楚如何改进我的实现，我使用了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)，这与仅实现单个循环相比是巨大的改进！