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

Question

我写了一个计算句子中单词（unigrams）个数的函数：

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)
  }
  )
}

为此，我使用了sapply-函数，它将我的get_unigrams-函数应用于数据集中的每一行。
到目前为止，这也有效：

##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

但是，由于get_unigrams-函数适用于每一行，因此非常耗时。 因此，我想问一下sapply-function 是否有一个快速的替代方案，可以显着加快我的get_unigrams-function。

##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 

对于包含 50,000 行的数据集，我的函数需要 22.06 秒（“verstrichen”）。这对我来说显然太多了！
有人可以帮我提高速度吗？也许用矢量化函数？

get_unigrams-function 中的构造必须保持不变：

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

我只指sapply-函数。
非常感谢！

Answer 1

根据您可能需要考虑替代包（而 ngram 声称速度很快）。这里最快的选择（当 ng = 1 时）是拆分单词并找到唯一索引。

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 

如果您想要更复杂（例如 ng != 1），则需要比较字符串的所有成对组合，这有点复杂。

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 

在这里，我们有一个额外的好处，即当特定单词的语料库中没有匹配的单词组合时不会崩溃。

我的 CPU 上的时间

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

替代并行实现：

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)

只是为了检查所有结果是否相同：

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

编辑：

当然，没有什么能阻止我们将并行化与上述任何结果相结合：

cl <- parallel::makeCluster(nc <- parallel::detectCores())
clusterEvalQ(cl, library(stringi))
system.time(
  res4 <- unname(unlist(parallel::parLapply(cl, 
                                            split(df$text, 
                                                  sort(1:nrow(df)%%nc)), 
                                            stringi_get_unigrams)))
)
#   user  system elapsed 
#   0.01    0.16    0.27
stopCluster(cl)

Answer 2

您可以通过将lapply 替换为lfuture_apply 来利用多个CPU 内核：

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