Действительно быстрая векторизация вектора вектора в R

Question

edit: Новый пакет text2vec отлично подходит и решает эту проблему (и многие другие) очень хорошо.

text2vec on CRAN text2vec on github vignette that illustrates ngram tokenization

У меня есть довольно большой текстовый набор данных в R, который я импортируемого как вектор символов:

#Takes about 15 seconds 
system.time({ 
    set.seed(1) 
    samplefun <- function(n, x, collapse){ 
    paste(sample(x, n, replace=TRUE), collapse=collapse) 
    } 
    words <- sapply(rpois(10000, 3) + 1, samplefun, letters, '') 
    sents1 <- sapply(rpois(1000000, 5) + 1, samplefun, words, ' ') 
}) 

я могу преобразовать эти символьные данные в bag- из следующих слов:

library(stringi) 
library(Matrix) 
tokens <- stri_split_fixed(sents1, ' ') 
token_vector <- unlist(tokens) 
bagofwords <- unique(token_vector) 
n.ids <- sapply(tokens, length) 
i <- rep(seq_along(n.ids), n.ids) 
j <- match(token_vector, bagofwords) 
M <- sparseMatrix(i=i, j=j, x=1L) 
colnames(M) <- bagofwords 

Таким образом, R может v ectorize 1,000,000 миллионов коротких предложений в мешок из-слов представления в течение примерно 3 секунд (не плохо!):

> M[1:3, 1:7] 
10 x 7 sparse Matrix of class "dgCMatrix" 
     fqt hqhkl sls lzo xrnh zkuqc mqh 
[1,] 1  1 1 1 .  . . 
[2,] .  . . . 1  1 1 
[3,] .  . . . .  . . 

я могу бросить эту разреженную матрицу в glmnet или irlba и сделать некоторые довольно удивительный количественный анализ текстовых данных , Ура!

Теперь я хотел бы распространить этот анализ на матрицу мешков, а не на матрицу слов. До сих пор самый быстрый способ я нашел, чтобы сделать это следующим образом (все функции Ngram я смог найти на CRAN подавился этого набора данных, так I got a little help from SO):

find_ngrams <- function(dat, n, verbose=FALSE){ 
    library(pbapply) 
    stopifnot(is.list(dat)) 
    stopifnot(is.numeric(n)) 
    stopifnot(n>0) 
    if(n == 1) return(dat) 
    pblapply(dat, function(y) { 
    if(length(y)<=1) return(y) 
    c(y, unlist(lapply(2:n, function(n_i) { 
     if(n_i > length(y)) return(NULL) 
     do.call(paste, unname(as.data.frame(embed(rev(y), n_i), stringsAsFactors=FALSE)), quote=FALSE) 
    }))) 
    }) 
} 

text_to_ngrams <- function(sents, n=2){ 
    library(stringi) 
    library(Matrix) 
    tokens <- stri_split_fixed(sents, ' ') 
    tokens <- find_ngrams(tokens, n=n, verbose=TRUE) 
    token_vector <- unlist(tokens) 
    bagofwords <- unique(token_vector) 
    n.ids <- sapply(tokens, length) 
    i <- rep(seq_along(n.ids), n.ids) 
    j <- match(token_vector, bagofwords) 
    M <- sparseMatrix(i=i, j=j, x=1L) 
    colnames(M) <- bagofwords 
    return(M) 
} 

test1 <- text_to_ngrams(sents1) 

Это занимает около 150 секунд (не плохо для чистой функции r), но я бы хотел пойти быстрее и расширить до больших наборов данных.

Есть ли очень быстро функции в R для векторизации текста n-грамм? В идеале я ищу функцию Rcpp, которая принимает вектор символов в качестве входных данных и возвращает разреженную матрицу документов x ngrams в качестве выходных данных, но также будет рада иметь некоторые рекомендации, непосредственно записывающие функцию Rcpp.

Даже более быстрая версия функции find_ngrams была бы полезна, так как это основное узкое место. R на удивление быстро наступает при токенизации.

Edit 1 Вот еще один пример набор данные:

sents2 <- sapply(rpois(100000, 500) + 1, samplefun, words, ' ') 

В этом случае, мои функции для создания сумки-из-слов матрицы занимает около 30 секунд, и моих функции для создания сумки-of ngrams занимает около 500 секунд. Опять же, существующие н-граммовые vectorizers в R, кажется, задушить этот набор данных (хотя я хотел бы быть опровергнуты!)

Edit 2 Timings против тау:

zach_t1 <- system.time(zach_ng1 <- text_to_ngrams(sents1)) 
tau_t1 <- system.time(tau_ng1 <- tau::textcnt(as.list(sents1), n = 2L, method = "string", recursive = TRUE)) 
tau_t1/zach_t1 #1.598655 

zach_t2 <- system.time(zach_ng2 <- text_to_ngrams(sents2)) 
tau_t2 <- system.time(tau_ng2 <- tau::textcnt(as.list(sents2), n = 2L, method = "string", recursive = TRUE)) 
tau_t2/zach_t2 #1.9295619 

Answer 1

Это действительно интересная проблема, и тот, который я провел много времени, сражаясь в пакете quanteda. Он включает в себя три аспекта, которые я буду комментировать, хотя это только третий, который действительно затрагивает ваш вопрос. Но первые два момента объясняют, почему я сосредоточен только на функции создания ngram, поскольку, как вы указываете, именно здесь можно улучшить скорость.

1. Tokenization. Здесь вы используете string::str_split_fixed() на символе пробела, который является самым быстрым, но не лучшим методом для токенизации. Мы реализовали это почти точно так же, как и в quanteda::tokenize(x, what = "fastest word"). Это не самое лучшее, потому что stringi может сделать гораздо более разумные реализации пробелов. (Даже класс символов \\s умнее, но немного медленнее - это реализовано как what = "fasterword"). Однако ваш вопрос касался не токенизации, а потому этот пункт является просто контекстом.

2. Вкладка матрицы признаков документа. Здесь мы также используем пакет Matrix и индексируем документы и функции (я называю их функциями, а не терминами) и создаю разреженную матрицу напрямую, как в коде выше. Но ваше использование match() намного быстрее, чем методы совпадения/слияния, которые мы использовали через data.table. Я собираюсь перекодировать функцию quanteda::dfm(), так как ваш метод более элегантный и быстрый. Действительно, очень рад, что я это увидел!

3. ngram creation. Здесь я думаю, что могу реально помочь с точки зрения производительности. Мы реализуем это в quanteda через аргумент quanteda::tokenize(), называемый grams = c(1), где это значение может быть любым целым набором. Например, наш матч для униграмм и биграмм будет ngrams = 1:2. Вы можете проверить код на https://github.com/kbenoit/quanteda/blob/master/R/tokenize.R, см. Внутреннюю функцию ngram(). Я воспроизвел это ниже и сделал обертку, чтобы мы могли напрямую сравнить ее с вашей функцией find_ngrams().

Код:

# wrapper 
find_ngrams2 <- function(x, ngrams = 1, concatenator = " ") { 
    if (sum(1:length(ngrams)) == sum(ngrams)) { 
     result <- lapply(x, ngram, n = length(ngrams), concatenator = concatenator, include.all = TRUE) 
    } else { 
     result <- lapply(x, function(x) { 
      xnew <- c() 
      for (n in ngrams) 
       xnew <- c(xnew, ngram(x, n, concatenator = concatenator, include.all = FALSE)) 
      xnew 
     }) 
    } 
    result 
} 

# does the work 
ngram <- function(tokens, n = 2, concatenator = "_", include.all = FALSE) { 

    if (length(tokens) < n) 
     return(NULL) 

    # start with lower ngrams, or just the specified size if include.all = FALSE 
    start <- ifelse(include.all, 
        1, 
        ifelse(length(tokens) < n, 1, n)) 

    # set max size of ngram at max length of tokens 
    end <- ifelse(length(tokens) < n, length(tokens), n) 

    all_ngrams <- c() 
    # outer loop for all ngrams down to 1 
    for (width in start:end) { 
     new_ngrams <- tokens[1:(length(tokens) - width + 1)] 
     # inner loop for ngrams of width > 1 
     if (width > 1) { 
      for (i in 1:(width - 1)) 
       new_ngrams <- paste(new_ngrams, 
            tokens[(i + 1):(length(tokens) - width + 1 + i)], 
            sep = concatenator) 
     } 
     # paste onto previous results and continue 
     all_ngrams <- c(all_ngrams, new_ngrams) 
    } 

    all_ngrams 
} 

Вот сравнение для простого текста:

txt <- c("The quick brown fox named Seamus jumps over the lazy dog.", 
     "The dog brings a newspaper from a boy named Seamus.") 
tokens <- tokenize(toLower(txt), removePunct = TRUE) 
tokens 
# [[1]] 
# [1] "the" "quick" "brown" "fox" "named" "seamus" "jumps" "over" "the" "lazy" "dog" 
# 
# [[2]] 
# [1] "the"  "dog"  "brings" "a"   "newspaper" "from"  "a"   "boy"  "named"  "seamus" 
# 
# attr(,"class") 
# [1] "tokenizedTexts" "list"  

microbenchmark::microbenchmark(zach_ng <- find_ngrams(tokens, 2), 
           ken_ng <- find_ngrams2(tokens, 1:2)) 
# Unit: microseconds 
#        expr  min  lq  mean median  uq  max neval 
# zach_ng <- find_ngrams(tokens, 2) 288.823 326.0925 433.5831 360.1815 542.9585 897.469 100 
# ken_ng <- find_ngrams2(tokens, 1:2) 74.216 87.5150 130.0471 100.4610 146.3005 464.794 100 

str(zach_ng) 
# List of 2 
# $ : chr [1:21] "the" "quick" "brown" "fox" ... 
# $ : chr [1:19] "the" "dog" "brings" "a" ... 
str(ken_ng) 
# List of 2 
# $ : chr [1:21] "the" "quick" "brown" "fox" ... 
# $ : chr [1:19] "the" "dog" "brings" "a" ... 

Для вашего действительно большого, моделируемого текста, вот сравнение:

tokens <- stri_split_fixed(sents1, ' ') 
zach_ng1_t1 <- system.time(zach_ng1 <- find_ngrams(tokens, 2)) 
ken_ng1_t1 <- system.time(ken_ng1 <- find_ngrams2(tokens, 1:2)) 
zach_ng1_t1 
# user system elapsed 
# 230.176 5.243 246.389 
ken_ng1_t1 
# user system elapsed 
# 58.264 1.405 62.889 

Уже улучшение, я был бы в восторге если это можно улучшить. Я также должен быть в состоянии реализовать быстрее dfm() метод в quanteda, так что вы можете получить то, что вы хотите просто через:

dfm(sents1, ngrams = 1:2, what = "fastestword", 
    toLower = FALSE, removePunct = FALSE, removeNumbers = FALSE, removeTwitter = TRUE)) 

(Это уже работает, но медленнее, чем ваш общий результат, потому что способ создания конечный разреженный матричный объект быстрее - но я скоро это изменил.)