r - In R distance between two sentence: Word-level comparison by minimum edit distance
问题描述
在尝试学习 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
我们将继续这样：“crashed”和“car”将是：
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）的函数。但是，我未能实现这一点。非常感谢您对此提供的帮助，谢谢。
解决方案
问题
在之前的帖子中进行了一些澄清之后，并且在帖子的更新之后，我的理解是零在问：'如何迭代地计算两个字符串中单词差异的数量'。
我不知道 R 中的任何实现，尽管如果我不存在我会感到惊讶。我花了一点时间来创建一个简单的实现，为了简单起见稍微改变了算法（对于不感兴趣的人，向下滚动查看 2 个实现，1 个在纯 R 中，一个使用最少的 Rcpp）。实现的总体思路：
string_1用和初始化string_2长度n_1和n_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。为此，我使用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
剖析
现在我发现运行时间非常慢。实施的一个用例可能是对学生提交的初步检查以检查抄袭，在这种情况下，低差异计数很可能表明抄袭。这些可能很长，可能有数百个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)，这与仅实现单个循环相比是一个巨大的改进！
推荐阅读
- php - 为什么 Laravel paginate() 没有按预期工作，但 simplePaginate() 可以？
- tensorflow - 使用 tensorflow 而不是 scikit-learn 进行回归有什么优势？
- perl - 如何将 mysql 数据插入 perl 图（已编辑）
- matlab - 使用 maltab 绘制矩阵
- sql - 从 SQL 视图返回有限的记录
- javascript - 如何在javascript中找到spintax组合的变化数量？
- python - 如何根据存储在值中的列表的第 n 个条目返回排序的键列表？
- android - 如何使用 FLAG_KEEP_SCREEN_ON 在 Flutter 中保持屏幕开启？
- python - python变量作为子进程中的参数
- google-api - 使用现代 Google API Node.js 客户端的批处理请求