R tm package выбирает огромное количество слов для хранения в текстовом корпусе - PullRequest
Новая
       34

R tm package выбирает огромное количество слов для хранения в текстовом корпусе

0 голосов
/ 27 апреля 2020

У меня есть около 70.000 frequent_words, которые я хочу сохранить в текстовом корпусе в том же порядке, в котором они появились (порядок имеет значение). Что я получил так: 

dtm <- DocumentTermMatrix(txt_corpus, control = list(wordLengths=c(1, Inf)))
frequent_words <- findFreqTerms(dtm, lowfreq=50)

Просто делать: 

dtm <- DocumentTermMatrix(txt_corpus, control = list(wordLengths=c(1, Inf)))
dtm <- removeSparseTerms(dtm, 0.8)

Не будет работать, так как мне нужно один и тот же фильтрованный text_corpus дважды: 

dtm <- DocumentTermMatrix(txt_corpus, control = list(wordLengths=c(1, Inf)))
BigramTokenizer <- function(x) unlist(lapply(ngrams(words(x), 2), paste, collapse = " "), use.names = FALSE)
bidtm <- DocumentTermMatrix(txt_corpus, control = list(tokenize = BigramTokenizer))

Я попробовал код ниже: 

keepWords <- content_transformer(function(x, words) {
  regmatches(x,
             gregexpr(paste0("(\\b",  paste(words, collapse = "\\b|\\b"), "\\b)"), x, perl = T, ignore.case=T, useBytes = T)
             , invert = T) <- " "
  return(x)
})
txt_corpus <- tm_map(txt_corpus, keepWords, frequent_words)

При запуске я получаю сообщение об ошибке: 

Error in gregexpr(paste0("(\\b", paste(words, collapse = "\\b|\\b"), "\\b)"),  : 
  assertion 'tree->num_tags == num_tags' failed in executing regexp: file 'tre-compile.c', line 634
Calls: preprocess ... tm_parLapply -> lapply -> FUN -> FUN -> regmatches<- -> gregexpr
Execution halted

Это вызвано длинным регулярным выражением. Удаление нечастых слов исключено, поскольку length(less_frequent_words)> 1.000.000 и занимает много времени с: 

chunk <- 500
n <- length(less_frequent_words)
r <- rep(1:ceiling(n/chunk),each=chunk)[1:n]
d <- split(less_frequent_words, r)

for (i in 1:length(d)) {
  txt_corpus <- tm_map(txt_corpus, removeWords, c(paste(d[[i]])))
}

Я также пробовал что-то с объединением, но это дает мне уникальный текстовый корпус в каждой итерации: 

chunk <- 500
n <- length(frequent_words)
r <- rep(1:ceiling(n/chunk),each=chunk)[1:n]
d <- split(frequent_words, r)

joined_txt_corpus <- VCorpus(VectorSource(list()))
for (i in 1:length(d)) {
  new_corpus <- tm_map(txt_corpus, keepWords, c(paste(d[[i]])))
  joined_txt_corpus <- c(joined_txt_corpus, new_corpus)
  txt_corpus <- tm_map(txt_corpus, removeWords, c(paste(d[[i]])))
}
txt_corpus <- joined_txt_corpus

Есть ли эффективный способ сделать такой же выбор, как text_corpus <- tm_map(txt_corpus, keepWords, frequent_words), но со многими словами? Любая помощь и советы приветствуются! Спасибо!

Воспроизводимый пример: 

library(tm)
data(crude)

txt_corpus <- crude

txt_corpus <- tm_map(txt_corpus, content_transformer(tolower))
txt_corpus <- tm_map(txt_corpus, removePunctuation)
txt_corpus <- tm_map(txt_corpus, stripWhitespace)

article_words <- c("a", "an", "the")
txt_corpus <- tm_map(txt_corpus, removeWords, article_words)
txt_corpus <- tm_map(txt_corpus, removeNumbers)

dtm <- DocumentTermMatrix(txt_corpus, control = list(wordLengths=c(1, Inf)))
frequent_words <- findFreqTerms(dtm, lowfreq=80)
dtm <- DocumentTermMatrix(txt_corpus, control = list(wordLengths=c(1, Inf), dictionary=frequent_words))

# Use many words just using frequent_words once works
# frequent_words <- c(frequent_words, frequent_words, frequent_words, frequent_words)

# keepWords function
keepWords <- content_transformer(function(x, words) {
  regmatches(x,
             gregexpr(paste0("(\\b",  paste(words, collapse = "\\b|\\b"), "\\b)"), x, perl = T, ignore.case=T)
             , invert = T) <- " "
  return(x)
})

txt_corpus <- tm_map(txt_corpus, keepWords, frequent_words)

# Get bigram from text_corpus
BigramTokenizer <- function(x) unlist(lapply(ngrams(words(x), 2), paste, collapse = " "), use.names = FALSE)
bidtm <- DocumentTermMatrix(txt_corpus, control = list(tokenize = BigramTokenizer))
bidtmm <- col_sums(bidtm)
bidtmm <- as.matrix(bidtmm)
print(bidtmm)

Вывод: 

        [,1]
in in     14
in of     21
in oil    19
in to     28
of in     21
of of     20
of oil    20
of to     29
oil in    18
oil of    18
oil oil   13
oil to    33
to in     32
to of     35
to oil    21
to to     41

1 Ответ

1 голос
/ 28 апреля 2020

Я посмотрел на ваши требования и, возможно, может помочь комбинация с ТМ и Quanteda. См. Ниже.

Получив список часто употребляемых слов, вы можете параллельно использовать quanteda для получения биграмм. 

library(quanteda)

# set number of threads 
quanteda_options(threads = 4) 

my_corp <- corpus(crude) # corpus from tm can be used here (txt_corpus)
my_toks <- tokens(my_corp, remove_punct = TRUE) # add extra removal if needed

# Use list of frequent words from tm. 
# speed gain should occur here
my_toks <- tokens_keep(my_toks, frequent_words)

# ngrams, concatenator is _ by default
bitoks <- tokens_ngrams(my_toks)

textstat_frequency(dfm(bitoks)) # ordered from high to low

   feature frequency rank docfreq group
1    to_to        41    1      12   all
2    to_of        35    2      15   all
3   oil_to        33    3      17   all
4    to_in        32    4      12   all
5    of_to        29    5      14   all
6    in_to        28    6      11   all
7    in_of        21    7       8   all
8   to_oil        21    7      13   all
9    of_in        21    7      10   all
10  of_oil        20   10      14   all
11   of_of        20   10       8   all
12  in_oil        19   12      10   all
13  oil_in        18   13      11   all
14  oil_of        18   13      11   all
15   in_in        14   15       9   all
16 oil_oil        13   16      10   all

quanteda имеет функцию topfeatures, но она не работает как findfreqterms. В противном случае вы могли бы сделать это полностью в Quanteda.

Если поколение dfm занимает слишком много памяти, вы можете использовать as.character для преобразования объекта токена и использовать его либо в dplyr, либо в data.table. См. Код ниже. 

library(dplyr)
out_dp <- tibble(features = as.character(bitoks)) %>% 
  group_by(features) %>% 
  tally()


library(data.table)
out_dt <- data.table(features = as.character(bitoks))
out_dt <- out_dt[, .N, by = features]
...