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

И другой ответ, использующий обычное расстояние Левенштейна (т.е. разрешающее вставку в любой точке), но на этот раз БЫСТРО - 1000 слов за 15 секунд быстро.

Хитрость заключается в использовании одной из быстрых реализаций Левенштейна, доступных в пакетах R; в этом случае я использую stringdist, но все должно работать. Проблема в том, что они работают со строками и символами, а не с многосимвольными представлениями фонем. Но для этого есть тривиальное решение: поскольку символов больше, чем фонем, мы можем просто перевести фонемы в отдельные символы. Результирующие строки не читаются как фонематическая транскрипция, но прекрасно работают в качестве входных данных для алгоритма плотности соседства.

library(stringdist)

phonemes <- unique(unlist(words))

# add a few buffer characters
targets <- c(letters, LETTERS, 0:9, "!", "§", "%", "&", "/", "=", 
             "#")[1:length(phonemes)]

ptmap <- targets
names(ptmap) <- phonemes

wordsT <- sapply(words, function(i) paste0(ptmap[i], collapse=""))

wordlengths <- nchar(wordsT)

onediffs.M <- function(x) {
  lengthdiff <-  abs(wordlengths - nchar(x))
  sum(stringdist(x, wordsT[lengthdiff == 0], method="hamming") == 1) +
    sum(stringdist(x, wordsT[lengthdiff == 1], method="lv") == 1)
}

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

get_one_diff <- function(words) {

  K <- max(le <- lengths(words))
  i_chr <- as.character(seq_len(K))
  words.spl <- split(words, le)

  test_substitution <- function(i) {
    word1 <- words[[i]]
    do.call(sum, lapply(words.spl[[i_chr[le[i]]]], function(word2) {
      sum(word1 != word2) == 1
    }))
  }

  test_addition <- function(i) {
    if ((le <- le[i]) == K) return(0)
    word1 <- words[[i]]
    do.call(sum, lapply(words.spl[[i_chr[le + 1]]], function(word2) {
      isOneDiff(word1, word2)
    }))
  }

  test_deletion <- function(i) {
    if ((le <- le[i]) == 1) return(0)
    word1 <- words[[i]]
    do.call(sum, lapply(words.spl[[i_chr[le - 1]]], function(word2) {
      isOneDiff(word2, word1)
    }))
  }

  sapply(seq_along(words), function(i) {
    test_substitution(i) + test_addition(i) + test_deletion(i)
  })
}

где isOneDiff — функция Rcpp:

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
bool isOneDiff(const StringVector& w1,
               const StringVector& w2) {

  int i, n = w1.size();

  for (i = 0; i < n; i++) if (w1[i] != w2[i]) break;
  for (     ; i < n; i++) if (w1[i] != w2[i+1]) return false;

  return true;
}

Это в 20 раз быстрее, чем ваша версия, и, поскольку это просто sapply, ее можно легко распараллелить.

Вот версия, использующая расстояние Левенштейна с алгоритмом Вагнера-Фишера.

vecLeven <- function(s, t) {
  d <- matrix(0, nrow = length(s) + 1, ncol=length(t) + 1)
  d[, 1] <- (1:nrow(d)) - 1
  d[1,] <- (1:ncol(d))-1
  for (i in 1:length(s))  {
    for (j in 1:length(t)) {
      d[i+1, j+1] <- min(
        d[i, j+1] + 1, # deletion
        d[i+1, j] + 1, # insertion
        d[i, j] + if (s[i] == t[j]) 0 else 1 # substitution
      )
    }
  }

  d[nrow(d), ncol(d)]
}


onediff <- sapply(words[1:10], function(x) {
  lengthdiff <- sapply(words, function(word) abs(length(word) - length(x)))
  sum(sapply(words[lengthdiff == 0], function(word) sum(word != x) == 1)) +
        sum(mapply(vecLeven, list(x), words[lengthdiff == 1]) == 1)
})

Я проверил обе версии на словаре CMU, который имеет аналогичный размер. Это немного быстрее вашей версии (около 30 секунд вместо 50 для 10 слов) и должно хорошо распараллеливаться. Тем не менее, запуск его на полном наборе данных занял бы несколько дней.

Одним из важных факторов производительности является то, что все пары вычисляются дважды, один раз для первого слова и один раз для второго; выполнение поиска вместо этого уменьшит это вдвое. Однако существует более 7 миллиардов пар, поэтому вам потребуется база данных для их хранения.