在R中加速大数据帧的处理 上下文

我一直在尝试实现最近在中提出的算法。在给定大量文本（语料库）的情况下，该算法应该返回语料库的特征n-gram（即n个单词的序列）。用户可以决定合适的n，目前我正在尝试使用原始文件中的n=2-6。换句话说，使用该算法，我想提取2到6克来描述语料库

我能够实现计算分数的部分，根据这些分数识别出特征n图，但一直在努力消除非特征n图

资料 我有一个名为

token.df

的列表，其中包含五个数据帧，包括语料库中出现的所有n-gram。每个数据帧对应于n克中的每个n。例如，

token.df[[2]]

按字母顺序包括所有的双字符（2克）及其分数（下面称为mi）

> head(token.df[[2]])
w1    w2      mi
_      eos  17.219346
_   global   7.141789
_     what   8.590394
0        0   2.076421
0       00   5.732846
0      000   3.426785

在这里，二元图0（尽管它们本身并不完全是单词）的分数为2.076421。由于数据帧包括语料库中出现的所有n-gram，因此它们每个都有超过一百万行

> sapply(token.df, nrow)
[[1]]
NULL

[[2]]
[1] 1006059  # number of unique bigrams in the corpus

[[3]]
[1] 2684027  # number of unique trigrams in the corpus

[[4]]
[1] 3635026  # number of unique 4-grams in the corpus

[[5]]
[1] 3965120  # number of unique 5-grams in the corpus

[[6]]
[1] 4055048  # number of unique 6-grams in the corpus

任务 我想确定哪些n-gram要保留，哪些要丢弃。为此，该算法执行以下操作

大人物

• 它保留了得分高于前两个单词匹配的三元图的四元图

3-5克

• 对于每个n-gram，其中n={3，4，5}，它将
  • 与n-gram的前n-1个单词匹配的n-1个gram和
  • 前n个单词与n-gram匹配的n+1个gram
• 该算法仅当其分数高于上述n-1克和n+1克的分数时才保留n克

6克

• 它保留了6克单词，其得分高于与6克单词前五个单词匹配的5克单词

例子 在这里，不保留二元图0 001，因为前两个单词与二元图（0 001狗）匹配的一个三叉图的得分高于二元图（11.002312>10.56292）。保留0 001三元图狗是因为其得分（11.002312）高于匹配三元图前两个单词的二元图（0 001；得分=10.56292）和匹配三元图前三个单词的四元图（0 001遛狗者；得分=10.916028）

问题和失败的尝试 我想知道的是实现上述目标的有效方法。例如，为了确定要保留哪些bigram，我需要为

token.df[[2]]

的每一行找出

token.df[[3]]

中哪些行的前两个单词与所关注的bigram相同。然而，由于行的数量很大，我下面的迭代方法运行时间太长。他们把重点放在双格纹的情况上，因为这项任务看起来比3-5克的情况简单

循环法的

。

由于下面的代码在每次迭代时都会遍历
token.df[[3]]
的所有行，因此估计需要几个月才能运行。虽然稍微好一点，但是
by（）
的情况类似

非常感谢任何加快代码速度的想法。
以下内容在我的机器上运行不到7秒，适用于所有Bigram：

library(dplyr)
res <- inner_join(token.df[[2]],token.df[[3]],by = c('w1','w2'))
res <- group_by(res,w1,w2)
bigrams <- filter(summarise(res,keep = all(mi.y < mi.x)),keep)

甚至更快（约2倍）。老实说，我甚至不确定我是否已经从这两个包中挤出了所有可能的速度


（从Rick处编辑。尝试作为注释，但语法混乱）

如果使用
data.table
，这应该更快，因为
data.table
具有
by-without-by
功能（有关更多信息，请参见
？data.table
）：

dt_tmp感谢您的及时回复。这正是我想要的！
# for loop
retain <- numeric(nrow(token.df[[2]]))
for (i in 1:nrow(token.df[[2]])) {
    mis <- token.df[[3]]$mi[token.df[[2]][i, ]$w1 == token.df[[3]][ , 1] & token.df[[2]][i, ]$w2 == token.df[[3]][ , 2]]
    retain[i] <- ifelse(token.df[[2]]$mi[i] > max(mis), TRUE, FALSE)
}

# by
mis <- by(token.df[[2]], 1:nrow(token.df[[2]]), function(x) token.df[[3]]$mi[x$w1 == token.df[[3]]$w1 & x$w2 == token.df[[3]]$w2])
retain <- sapply(seq(mis), function(i) token.df[[2]]$mi[i] > max(mis[[i]]))

retain <- numeric(nrow(token.df[[2]]))
nrow <- nrow(token.df[[3]]) # number of rows of the trigram data frame
pos <- 1 # pointer
for (i in seq(nrow(token.df[[2]]))) {
    j <- 1
    target.rows <- numeric(10)
    while (TRUE) {
        if (pos == nrow + 1 || !all(token.df[[2]][i, 1:2] == token.df[[3]][pos, 1:2])) break
        target.rows[j] <- pos
        pos <- pos + 1
        if (j %% 10 == 0) target.rows <- c(target.rows, numeric(10))
        j <- j + 1
    }
    target.rows <- target.rows[target.rows != 0]
    retain[i] <- ifelse(token.df[[2]]$mi[i] > max(token.df[[3]]$mi[target.rows]), TRUE, FALSE)
}

token.df <- list()
types <- combn(LETTERS, 4, paste, collapse = "")
set.seed(1)
data <- data.frame(matrix(sample(types, 6 * 1E6, replace = TRUE), ncol = 6), stringsAsFactors = FALSE)
colnames(data) <- paste0("w", 1:6)
data <- data[order(data$w1, data$w2, data$w3, data$w4, data$w5, data$w6), ]
set.seed(1)
for (n in 2:6) token.df[[n]] <- cbind(data[ , 1:n], mi = runif(1E6))

library(dplyr)
res <- inner_join(token.df[[2]],token.df[[3]],by = c('w1','w2'))
res <- group_by(res,w1,w2)
bigrams <- filter(summarise(res,keep = all(mi.y < mi.x)),keep)

library(data.table)
dt2 <- setkey(data.table(token.df[[2]]),w1,w2)
dt3 <- setkey(data.table(token.df[[3]]),w1,w2)
dt_tmp <- dt3[dt2,allow.cartesian = TRUE][,list(k = all(mi < mi.1)),by = c('w1','w2')][(k)]

 dt_tmp <- dt3[dt2,list(k = all(mi < i.mi)), allow.cartesian = TRUE][(k)]