高效计算列表出现的次数

Question

高效计算列表出现的次数

6

我有一个包含数百万个列表的列表，这些子列表具有一些不同的可能值，大约在10到100之间。

我想计算这些值的出现次数。

下面的代码有效，但速度非常慢。我们能更快地完成吗？

count_by_list <- function(lst, var_nm = as.character(substitute(lst)), count_nm = "n"){
  unique_lst <- unique(lst)
  res <- tibble::tibble(!!var_nm := unique_lst, !!count_nm := NA)
  for(i in seq_along(unique_lst)){
    res[[count_nm]][[i]] <- sum(lst %in% res[[var_nm]][i])
  }
  res
}

x <- list(
  list(a=1, b=2),
  list(a=1, b=2),
  list(b=3),
  list(b=3, c=4))

count_by_list(x)
#> # A tibble: 3 x 2
#>   x                    n
#>   <list>           <int>
#> 1 <named list [2]>     2
#> 2 <named list [1]>     1
#> 3 <named list [2]>     1

^{此文档由reprex package (v0.3.0)于2019-11-29创建}

我尝试使用库digest进行哈希，但实际上速度更慢了，并且随着n的增加而变得越来越糟糕：

library(digest)
count_by_list2 <- function(lst, var_nm = as.character(substitute(lst)), count_nm = "n"){
  unique_lst <- unique(lst)
  digested   <- vapply(lst, digest, character(1))
  res        <- as.data.frame(table(digested))
  names(res) <- c(var_nm, count_nm)
  res[[1]] <- unique_lst
  res
}

如果你需要进行基准测试，可以使用x_big <- unlist(replicate(10000 ,x, F), recursive = FALSE)。我添加了rcpp和parallel processing标签，因为它们可能有所帮助，但答案并不受其限制。

- moodymudskipper

也许我误解了你的问题，但是你是想计算你的“主”列表中独特列表的数量吗？ - edsandorf

不，对于每个唯一的列表，我想知道它出现的次数。在我的例子中，我有3个唯一的列表，第一个出现了2次，其他只出现了一次。这些就是我要找的数字。 - moodymudskipper

从技术上讲，这不是一个合适的问题，因为你不应该问“请帮我用（最好是并行化的）C++ 重写这个”。 - Dirk Eddelbuettel

1

这不是我想问的，我甚至不知道C++是否是正确的选择，Dirk，是吗？如果是的话，我很乐意得到一些提示，也许会回来编辑或提出更具体的问题。 - moodymudskipper

但这是您要求的;-) - 所以也许现在是删除这两个标签的时候了？我认为 data.table 已经能够通过其算法给您非常快速的排序和计数（请记住：基本R使用其算法），以及可能的 openmp 并行性。 - Dirk Eddelbuettel

我认为我们对标记的含义并不一致，我正在查阅常见问题和元数据，如果改变我的想法，我会进行删除。对我来说，问题的一部分是rcpp和并行处理可能是相关的，因此标签是恰当的，如果您想进一步争论，我也会倾听。 - moodymudskipper

3个回答

5

这里是一个简单粗暴的东西，可以删去原始解决方案。

cbl2 <- function(x) {
  xcv <- vapply(seq_along(x), function(i) paste(x[i]), character(1))
  xcv_count <- table(match(xcv, xcv))
  tibble(x = x[as.integer(names(xcv_count))], n = as.vector(xcv_count))  
}

再次使用data.table进行一些实验，缩短了运行时间：

cbl3 <- function(x) {
  data.table(xlist = x)[, xstring := paste(xlist), by = 1:length(x)
                        ][, .(x = xlist[1], .N), by = xstring
                          ][, .(x, n = N)
                            ][, as_tibble(.SD)]
}

- s_baldur

我确实节省了一半的时间。我试图破坏它，但到目前为止它都很顽强 :) - moodymudskipper

1

通过仅使用as.character（作为vapply中的函数）而避免使用paste的开销似乎更快。 - alexis_laz

0

也许以下代码可以运行

df <- data.frame(table(sapply(x_big, function(v) paste0(c(names(z<-unlist(v)),z),collapse = ","))))

这提供了

> df
     Var1 Freq
1 a,b,1,2    2
2     b,3    1
3 b,c,3,4    1

运行时间比较：在x_big中有4e5个元素

x_big <- unlist(replicate(100000 ,x, F),  recursive = FALSE)

# my solution
t1 <- Sys.time()
df <- data.frame(table(sapply(x_big, function(v) paste0(c(names(z<-unlist(v)),z),collapse = ","))))
w1 <- Sys.time() - t1

#author's solution
t2 <- Sys.time()
count_by_list <- function(lst, var_nm = as.character(substitute(lst)), count_nm = "n"){
  unique_lst <- unique(lst)
  res <- tibble::tibble(!!var_nm := unique_lst, !!count_nm := NA)
  for(i in seq_along(unique_lst)){
    res[[count_nm]][[i]] <- sum(lst %in% res[[var_nm]][i])
  }
  res
}
count_by_list(x_big)
w2 <- Sys.time()-t2

> c(w1,w2)
Time differences in secs
[1] 3.591747 8.058480

- ThomasIsCoding

如果你有一个像下面这样的列表list(b=1, c=2)，这个会失败吗？ - s_baldur

@sindri_baldur 嗯...你说得对...这是我解决方案中的一个问题。非常感谢，我会尝试修复它。 - ThomasIsCoding

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Cole · Accepted Answer

这种data.table方法比针对x_big示例的OP原始循环快30倍。需要注意的一点是，如果子列表中的任何元素包含多个记录，则此方法将失败。

library(data.table)

molten_lst <- rbindlist(x, fill = T)
cnt_lst <- molten_lst[, .N, names(molten_lst)]

tibble(x = cnt_lst[, 
                   list(apply(.SD, 1, function(x) as.list(na.omit(x)))),
                   .SDcols = names(molten_lst),
                   by = .(seq_len(nrow(cnt_lst)))]$V1,
           n = cnt_lst[['N']])

这里有两种备份方法。我遇到了NSE /准引用问题，所以 !!var_nam 被简化了。第一种方法是对您原始函数的一些调整-主要是在循环期间过滤 lst 。

enhanced_loop <- function(lst, var_nm = as.character(substitute(lst)), count_nm = "n"){
  unique_lst <- unique(lst)
  cnts <- vector('integer', length(unique_lst))

  for (i in seq_along(unique_lst)[-length(unique_lst)]){
    ind <- lst %in% unique_lst[i]
    lst <- lst[!ind]
    cnts[i] <- sum(ind)
  }
  cnts[length(unique_lst)] <- length(lst)
  tibble::tibble(x := unique_lst, !!count_nm := cnts)
}

这将循环带到逻辑结论 - 使用match()而不是%in%，以避免重复努力：

tabulate_match <- function(lst, var_nm = as.character(substitute(lst)), count_nm = "n"){
  unique_lst <- unique(lst)
  cnts <- tabulate(match(lst, unique_lst))
  tibble::tibble(x := unique_lst, !!count_nm := cnts)
}

性能：

# A tibble: 7 x 13
  expression                min  median `itr/sec` mem_alloc `gc/sec` n_itr
  <bch:expr>              <bch> <bch:t>     <dbl> <bch:byt>    <dbl> <int>
1 molten_dt                25ms  25.1ms     39.7     2.71MB     0        5
2 tabulate_match(x_big)   237ms 247.2ms      3.41    1.42MB     2.05     5
3 enhanced_loop(x_big)    344ms 352.6ms      2.82    2.83MB     1.69     5
4 table_sapply            381ms 384.9ms      2.59    3.76MB     7.77     5
5 vapply_tab_match(x_big) 412ms 429.3ms      2.14    4.21MB     3.85     5
6 dt_thing(x_big)         442ms 464.6ms      2.15    2.83MB     7.31     5
7 count_by_list(x_big)    759ms 768.4ms      1.24     3.4MB     2.23     5