在 R 中两个句子之间的距离：Word-level 按最小编辑距离比较
In R distance between two sentences: 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".
但是，我们如何才能自动找到这样的操作次数。
我们可以有几个动作来转换句子：添加、删除或替换列表中的单词。
现在，我将尽力解释算法应该如何工作：
第一步：我将像这样创建一个 table：
行：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
现在，我将尝试填写table。请注意，table 中的每个单元格都显示了我们需要执行的操作数来重新格式化句子（添加、删除或替换）。
考虑 "crashed" 和 "crashed" (value[1,1]) 之间的交互，显然我们不需要改变它所以 value将是 '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
因此，我们只需要删除 "red"。
因此，table 将如下所示：
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
而 table 将是：
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
如你所见，table 中的最后一个数字显示了两个句子之间的距离：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
为了找到您可以在 header 和矩阵列中看到的两个列表的元素之间的差异，我使用了 strcmp() 函数，它将为我们提供一个布尔值（真或假）同时比较单词。但是，我未能实现这一点。
感谢您对此提供帮助，谢谢。
问题
经过之前post的一些澄清，以及post的更新后，我的理解是零在问：'how one can iteratively count the number of word differences in two strings'。
我不知道 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 遍历 rows/columns（两者都有效），我们从第三个对角线开始，因为第一个 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
}
请注意，该实现不是矢量化的，因此只能接受单个字符串输入！
测试实施
要测试实现，可以使用给定的字符串。由于据说它们包含在列表中，我们必须将它们转换为字符串。请注意，该函数允许以不同方式拆分每个字符串，但它假定 space 分隔字符串。因此，首先我将展示如何转换为正确的格式：
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，则比较速度会快得多。
对实施进行基准测试
现在，由于实现被接受并且正确，我们想知道它的性能如何（对于不感兴趣的人 reader，可以滚动到此部分，到提供更快实现的地方）。为此，我将使用更大的字符串。对于一个完整的基准测试，我应该测试各种字符串大小，但出于目的，我将只使用 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
分析
现在我发现 运行-times 非常慢。实施的一个用例可能是对学生上交的初步检查以检查是否存在抄袭，在这种情况下，低差异计数很可能表明存在抄袭。这些可能很长，可能有数百个提交，因此我希望 运行 非常快。
为了弄清楚如何改进我的实现，我使用了 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) 的微基准测试中值改进因子来看，这是仅实施单个循环的巨大改进！
我们可以利用 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).
在尝试学习 R 时，我想在 R 中实现以下算法。请考虑以下两个列表：
List 1: "crashed", "red", "car"
List 2: "crashed", "blue", "bus"
我想知道将 'list1' 转换为 'list2' 需要多少次操作。
如您所见，我只需要执行两个操作：
1. Replace "red" with "blue".
2. Replace "car" with "bus".
但是，我们如何才能自动找到这样的操作次数。 我们可以有几个动作来转换句子：添加、删除或替换列表中的单词。 现在，我将尽力解释算法应该如何工作：
第一步：我将像这样创建一个 table：
行：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
现在，我将尝试填写table。请注意，table 中的每个单元格都显示了我们需要执行的操作数来重新格式化句子（添加、删除或替换）。
考虑 "crashed" 和 "crashed" (value[1,1]) 之间的交互，显然我们不需要改变它所以 value将是 '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
因此，我们只需要删除 "red"。 因此，table 将如下所示：
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
而 table 将是：
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
如你所见，table 中的最后一个数字显示了两个句子之间的距离：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
为了找到您可以在 header 和矩阵列中看到的两个列表的元素之间的差异，我使用了 strcmp() 函数，它将为我们提供一个布尔值（真或假）同时比较单词。但是，我未能实现这一点。
感谢您对此提供帮助，谢谢。
问题
经过之前post的一些澄清，以及post的更新后，我的理解是零在问：'how one can iteratively count the number of word differences in two strings'。
我不知道 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 遍历 rows/columns（两者都有效），我们从第三个对角线开始，因为第一个 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
}
请注意，该实现不是矢量化的，因此只能接受单个字符串输入！
测试实施
要测试实现，可以使用给定的字符串。由于据说它们包含在列表中，我们必须将它们转换为字符串。请注意，该函数允许以不同方式拆分每个字符串，但它假定 space 分隔字符串。因此，首先我将展示如何转换为正确的格式：
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，则比较速度会快得多。
对实施进行基准测试
现在，由于实现被接受并且正确，我们想知道它的性能如何（对于不感兴趣的人 reader，可以滚动到此部分，到提供更快实现的地方）。为此，我将使用更大的字符串。对于一个完整的基准测试，我应该测试各种字符串大小，但出于目的，我将只使用 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
分析
现在我发现 运行-times 非常慢。实施的一个用例可能是对学生上交的初步检查以检查是否存在抄袭，在这种情况下，低差异计数很可能表明存在抄袭。这些可能很长，可能有数百个提交，因此我希望 运行 非常快。
为了弄清楚如何改进我的实现，我使用了 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) 的微基准测试中值改进因子来看，这是仅实施单个循环的巨大改进！
我们可以利用 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).