Вопрос
После некоторых разъяснений в предыдущем посте и после обновления поста я понимаю, что Ноль спрашивает: «Как можно итеративно подсчитать количество различий в словах в двух строках»,
Мне неизвестно о какой-либо реализации в R, хотя я был бы удивлен, если бы я еще не существовал.Я потратил немного времени на создание простой реализации, слегка изменив алгоритм для простоты (для всех, кто не заинтересован, прокрутите вниз до 2 реализаций, 1 в чистом R, один из которых использует наименьшее количество Rcpp).Общая идея реализации:
- Инициализация с
string_1 и string_2 длины n_1 и n_2 - Вычисление совокупной разности между первым
min(n_1, n_2)elements, - Используйте эту кумулятивную разницу в качестве диагонали в матрице
- Установите первый недиагональный элемент на самый первый элемент + 1
- Рассчитайте оставшиеся недиагональные элементыas:
diag(i) - diag(i-1) + full_matrix(i-1,j) - На предыдущем шаге я перебираю диагонали, j перебирает строки / столбцы (любой из них работает), и мы начинаем с третьей диагонали, поскольку первая матрица 2x2 заполняется на шаге 14
- Рассчитайте оставшиеся
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)
output
#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. Для этой цели я использую пакет microbenchmark в R, который содержит функцию 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 для повышения производительности
Чтобы улучшить реализацию, мы могли бы реализовать цикл в c ++ с использованием пакета Rcpp.Это довольно просто.Код мало чем отличается от того, который мы использовали бы в 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), что является значительным улучшением по сравнению с простой реализацией одного цикла!