R 为 sapply() 寻找更快的替代方案

Question

I have written a function that counts the number of words (unigrams) in a sentence:

library(ngram)
library(stringi)
library(tidyverse)
set.seed(123)

get_unigrams <- function(text) {
  sapply(text, function(text){
    unigram<-  ngram(text, n = 1) %>% get.ngrams() %>% length()
    
    return(unigram)
  }
  )
}

To do this, I used the sapply -function that applies my get_unigrams -function to each row in the data set.
This also works so far:

##example dataset:
df<-sample.int(5, 5, replace = T) %>% 
  map(.,  ~ stri_rand_strings(.x, 10) %>% paste(collapse = " ")) %>%
  unlist() %>% 
  tibble(text = .)

##applying my function
df %>% mutate(n=get_unigrams((text)))

# A tibble: 5 x 2
  text                                 n
  <chr>                            <int>
1 SxSgZ6tF2K xtgdzehXaH 9xtgn1TlDJ     3
2 E8PPM98ESG r2Rn7YC7kt Nf5NHoRoon     3
3 Rkdi0TDNbL 6FfPm6Qzts                2
4 A8eLeJBm5S VbKUxTtubP                2
5 9vI3wi8Yxa PeJJDMz958 gctfjWeomy     3

However, since the get_unigrams -function is applied for each row, this is very time-consuming. Therefore, I would like to ask if there is an fast alternative for the sapply -function that speeds up my get_unigrams -function significantly.

##dataset with 50.000 rows:
df<-sample.int(50, 50000, replace = T) %>% 
  map(.,  ~ stri_rand_strings(.x, 10) %>% paste(collapse = " ")) %>%
  unlist() %>% 
  tibble(text = .)


system.time({
  df %>% mutate(n=get_unigrams((text)))
})

#      User      System verstrichen 
#     21.35        0.11       22.06 

For a data set with 50,000 rows, my function needs 22.06 seconds ("verstrichen"). This is clearly too much for me!
Can someone help me increase the speed? Maybe with a vectorised function?

The construct within the get_unigrams -function must remain the same:

unigram <- ngram(text, n = 1) %>% get.ngrams() %>% length()    
return(unigram)

I am only referring to the sapply -function.
Many thanks in advance!

Answer 1

You can utilize multiple CPU cores by replacing lapply with lfuture_apply :

library(dplyr)
library(future.apply)

my_slow_func <- function(x) {
  Sys.sleep(1)
  x + 1
}

data <- head(iris, 3)
data

system.time(
  mutate(data, a = Sepal.Length %>% map(my_slow_func))
)
#   user  system elapsed 
#  0.010   0.001   3.004 

plan(multisession)
chunks <- split(data, seq(3))
system.time(
  data$a <- future_lapply(chunks, function(x) my_slow_func(x$Sepal.Length))
)
#   user  system elapsed 
#  0.064   0.003   1.167 

Answer 2

Depending on your might want to consider alternative packages (while ngram proclaims to be fast). The fastest alternative here (while ng = 1) is to split the word and find unique indices.

stringi_get_unigrams <- function(text)
  lengths(lapply(stri_split(text, fixed = " "), unique))

system.time(res3 <- stringi_get_unigrams(df$text))
#   user  system elapsed 
#   0.84    0.00    0.86 

If you want to be more complex (eg. ng,= 1) you'd need to compare all pairwise combinations of string. which is a bit more complex.

stringi_get_duograms <- function(text){
  splits <- stri_split(text, fixed = " ")
  comp <- function(x)
    nrow(unique(matrix(c(x[-1], x[-length(x)]), ncol = 2)))
  res <- sapply(splits, comp)
  res[res == 0] <- NA_integer_
  res
}
system.time(res <- stringi_get_duograms(df$text))
#   user  system elapsed 
#   5.94    0.02    5.93 

Here we have the added benefit of not crashing when there's no word combinations that are matching in the corpus of the specific words.

Times on my CPU

system.time({
  res <- get_unigrams(df$text)
})
#   user  system elapsed 
#  12.72    0.16   12.94 

alternative parallel implementation:

get_unigrams_par <- function(text) {
  require(purrr)
  require(ngram)
  sapply(text, function(text)
    ngram(text, n = 1) %>% get.ngrams() %>% length()
  )
}
cl <- parallel::makeCluster(nc <- parallel::detectCores())
print(nc)
# [1] 12
system.time(
res2 <- unname(unlist(parallel::parLapply(cl, 
                                         split(df$text, 
                                               sort(1:nrow(df)%%nc)), 
                                         get_unigrams_par)))
)
#   user  system elapsed 
#   0.20    0.11    2.95 
parallel::stopCluster(cl)

And just to check that all results are identical:

identical(unname(res), res2)
# TRUE
identical(res2, res3)
# TRUE