R：查找并计算嵌套在列表中的字符向量之间按位置（添加、减去或替换的一个元素）的所有差异

Question

我有一个字符向量列表，表示按音素拆分的单词：

> head(words)
[[1]]
[1] "UU"

[[2]]
[1] "EY" "Z" 

[[3]]
[1] "T"  "R"  "IH" "P"  "UU" "L"  "EY"

[[4]]
[1] "AA" "B"  "ER" "G" 

[[5]]
[1] "AA" "K"  "UU" "N" 

[[6]]
[1] "AA" "K"  "ER"

对于列表中的每个单词，我想找到与所考虑的单词相差一个音素（添加、减去或替换一个音素）并且具有相同数量的单词的数量相同位置的音素。从这个意义上说，对于单词 "EY" "Z" 可接受的情况是：

[1] "M"  "EY" "Z" 

[1] "AY" "Z"

[1] "EY" "D" 

[1] "EY" "Z" "AH"

但应拒绝以下情况：

[1] "EY" "D"  "Z"

[1] "Z" "EY" "D"

[1] "HH" "EY"

基本上，我想找出一个元素在向量中音素位置方面的差异。目前，我找到的最佳解决方案是：

diffs <- c()
for (i in seq_along(words)) {
  diffs <- c(diffs, sum(sapply(words, function(y) {
    count <- 0
    elements <- list(words[[i]], y)
    len <- c(length(words[[i]]), length(y))
    if (identical(elements[which(len==max(len))][[1]][-1], elements[which(len==min(len))][[1]]) == 1) {
      count + identical(elements[which(len==max(len))][[1]][-1], elements[which(len==min(len))][[1]])
    } else {
      length(elements[which(len==min(len))][[1]]) <- length(elements[which(len==max(len))][[1]])
      elements <- rapply(elements, f=function(x) ifelse(is.na(x),"$$",x), how="replace" )
      count + sum(elements[[1]] != elements[[2]])
    }
  })== 1))
}

但是，这个解决方案需要很长时间，因为我的列表 words 有 120.000 个元素 (words/vectors)，所以我想问问你是否知道其他解决方案来加速这个过程。

非常感谢您的回答

Answer 1

这是一个使用编辑距离和 Wagner-Fischer 算法的版本。

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 秒而不是 10 个单词的 50 秒），并且应该很好地并行化。尽管如此，运行它在完整的数据集上仍需要几天时间。

一个重要的性能因素是所有对都计算两次，一次用于第一个单词，一次用于第二个；相反，进行查找会将其减半。但是，有超过 70 亿对，因此您需要一个数据库来存储它们。

Answer 2

因此，这里的关键是根据单词的长度将单词分开，这样我们就可以仅在感兴趣的子集上测试每个假设 (substitution/addition/deletion)。

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，可以很容易地并行化。

Answer 3

还有一个不同的答案，使用常规 Levenshtein 距离（即允许在任何点插入），但这次是快速 - 15 秒内快速 1000 个单词。

诀窍是使用 R 包中提供的一种快速 Levenshtein 实现；在这种情况下，我使用的是 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)
}

R：查找并计算嵌套在列表中的字符向量之间按位置（添加、减去或替换的一个元素）的所有差异

R: find and count all differences by position (of one element added, subtracted or substituted) between character vectors nested in a list

r

performance

position

set-difference