Быстрая количественная оценка перекрытия векторов символов

Question

Таким образом, я в основном пытаюсь реализовать упрощенную версию ROUGE (метрика уровня предложений для пословного сходства строк), потому что я пытаюсь выровнять продукты из двух источников данных, где порядок слов иногда слегка переворачиваетсяили некоторые слова опущены в одном источнике.

Мне нужно: а) разбить все строки на биграммы, б) сравнить каждый набор биграмм из одного набора данных с каждым набором биграмм из другого набора данных (набор, являющийся биграммами)который пришел из одного элемента в начальном символьном векторе), и c) вывести метрику перекрытия биграмм.

Вот моя функция:

rougenscore <- function(sys, ref, n = 2, metric = c("f-score","precision","recall")) {
  metric <- match.arg(metric)
  tidysys <- enframe(sys, name = "ID", value = "text") %>%
    unnest_tokens(ngram, text, token = "ngrams", n = n)
  tidyref <- enframe(ref, name = "ID", value = "text") %>%
    unnest_tokens(ngram, text, token = "ngrams", n = n)
  if (metric %in% c("f-score","precision")) {
    precision <- matrix(nrow = length(sys), ncol = length(ref), dimnames = list(sys, ref))
  }
  if (metric %in% c("f-score","recall")) {
    recall <- matrix(nrow = length(sys), ncol = length(ref), dimnames = list(sys, ref))
  }

  #Loops through all elements in sys and all elements in ref and compares them pairwise
  for (i in 1:length(sys)) {
    for (j in 1:length(ref)) {
      seti <- tidysys %>%
        filter(ID == i) %>%
        distinct(ngram) #We'll be using sets and set theory here, hence distinct
      setj <- tidyref %>%
        filter(ID == j) %>%
        distinct(ngram)
      if (metric %in% c("f-score","precision")) {
        precision[i,j] <- length(intersect(seti$ngram, setj$ngram))/length(seti$ngram)
      }
      if (metric %in% c("f-score","recall")) {
        recall[i,j] <- length(intersect(seti$ngram, setj$ngram))/length(setj$ngram)
      }
    }
  }
  #This switch case returns the requested metric (as a matrix)
  switch (metric,
          "f-score" = (2 * (precision * recall) / (precision + recall)),
          "recall" = recall,
          "precision" = precision
  )
}

Я подтвердил, что она работает, но цикл for очень медленный, и я пытаюсь сравнить вектор из примерно 4000 строк с вектором из примерно 6000 строк.Я помню, как работал с ROUGE на других языках, но это довольно дорогостоящий процесс, но я бы хотел ускорить его, если смогу.Не беспокоит токенизация биграмм, потому что это делается только один раз, но мне интересно, может быть, есть лучший способ подсчитать количество идентичных элементов в двухсимвольных векторах, чем intersect().Или, может быть, вызовы filter() / distinct() могут быть ускорены за пределами dplyr?

Для справки, строки - это названия продуктов, и большинство из них, вероятно, находятся в диапазоне 3-10 слов.Таким образом, количество биграмм, сравниваемых в данном проходе внутреннего цикла, довольно мало.