R：加快功能的建议（删除数据框中的重复项）

Question

我的代码遇到了一些问题，欢迎提出任何建议以使其运行得更快。 我有一个看起来像这样的数据框：

Name <- c("a","a","a","a","a","b","b","b","b","c")

Category <- c("sun","cat","sun","sun","sea","sun","sea","cat","dog","cat")

More_info <- c("table","table","table","table","table","table","table","table","table","cat")
d <- data.frame(Name,Category,More_info)

所以我在名称列中的每一行都有重复的条目（重复的数量可能会有所不同）。对于每个条目（a，b，...），我想计算 Category 列中每个相应元素的总和，并保留唯一出现最多的类别。如果一个条目具有相同数量的类别，我想随机选取大多数类别之一。 所以在这种情况下，输出数据框将如下所示：

Name <- c("a","b","c")

Category <- c("sun","dog","cat")

More_info <- c("table","table","table")
d <- data.frame(Name,Category,More_info)

a 保留 sun 条目，因为它出现最多，b 将是 dog 或任何其他值，因为它们都与 b 一起出现一次，并且 c 不会改变。 我的函数如下所示：

    my_choosing_function <- function(x){
      tmp = dbSNP_hapmap[dbSNP_hapmap$refsnp_id==list_of_snps[x],]
      snp_freq <- as.data.frame(table(tmp$consequence_type_tv)) 
       best_hit <- snp_freq[order(-snp_freq$Freq),]
      best_hit$SNP<-list_of_snps[x]
      top<-best_hit[1,]
      return(top)
    }
    trst <- lapply(1:length(list_of_snps), function(x) my_choosing_function(x))
final <- do.call("rbind",trst)

我从一个唯一元素列表（在我们的例子中是名称）开始，对于每个元素我做一个重复条目的表格，我按降序排列表格并保留顶部元素。我对唯一值列表中的每个元素执行一次 lapply，然后对整个内容执行一次 rbind。

由于我的初始数据框中有 2500000 行和 1500000 个唯一元素，因此它需要很长时间才能运行。 100 行需要 4 秒，那么 lapply 总共需要 34 小时。

我确信像 dplyr 这样的软件包可以在几分钟内完成，但找不到解决方案。有人有想法吗？ 非常感谢您的帮助！

Answer 1

对@mt1022 的解决方案进行一些细微的调整可以产生边际加速，没有什么可以打电话回家的，但如果你发现你的数据增长了另一个数量级，可能会有用。

library(data.table)
library(dplyr)

d <- data.frame(
 Name = as.character(sample.int(10000, 2.5e6, replace = T)),
 Category = as.character(sample.int(5000, 2.5e6, replace = T)),
 More_info = rep('table', 2.5e6)
)

Mode <- function(x) {
 ux <- unique(x)
 fr1 <- tabulate(match(x, ux))
 if(n_distinct(fr1)==1) ux[sample(seq_along(fr1), 1)] else ux[which.max(fr1)]
}

system.time({
 d %>%
   group_by(Name) %>%
   slice(which(Category == Mode(Category))[1])
})

# user   system elapsed 
# 40.459   0.180  40.743 

system.time({
 dt <- as.data.table(d)
 dt.max <- dt[, .N, by = .(Name, Category)]
 dt.max[, r := frank(-N, ties.method = 'random'), by = .(Name)]
 dt.max <- dt.max[r == 1, .(Name, Category)]

 dt[dt.max, on = .(Name, Category), mult = 'first']
})

# user  system elapsed 
# 4.196   0.052   4.267 

调整包括

• 使用setDT() 而不是as.data.table() 以避免复制
• 使用stats::runif()直接生成随机决胜局，这是data.table在frank()的随机选项内部所做的
• 使用setkey()对表格进行排序
• 通过行索引.I 对表进行子设置，其中每组中的行等于每组中的观察数.N。 （返回每组的最后一行）

结果：

system.time({
 dt.max <- setDT(d)[, .(Count = .N), keyby = .(Name, Category)]
 dt.max[,rand := stats::runif(.N)]
 setkey(dt.max,Name,Count, rand)
 dt.max[dt.max[,.I[.N],by = .(Name,Category)]$V1,.(Name,Category,Count)]
})

# user  system elapsed 
# 1.722   0.057   1.750 

Answer 2

注意：这应该是一个很长的评论，因为我使用data.table 而不是dplyr。

我建议使用data.table，因为它运行得更快。并且在下面显示的data.table 方式中，它随机选择一个以防平局，而不总是第一个。

library(data.table)
library(dplyr)
library(microbenchmark)

d <- data.frame(
    Name = as.character(sample.int(10000, 2.5e6, replace = T)),
    Category = as.character(sample.int(10000, 2.5e6, replace = T)),
    More_info = rep('table', 2.5e6)
)

Mode <- function(x) {
    ux <- unique(x)
    fr1 <- tabulate(match(x, ux))
    if(n_distinct(fr1)==1) ux[sample(seq_along(fr1), 1)] else ux[which.max(fr1)]
}

system.time({
    d %>%
        group_by(Name) %>%
        slice(which(Category == Mode(Category))[1])
})
#    user  system elapsed
#  45.932   0.808  46.745

system.time({
    dt <- as.data.table(d)
    dt.max <- dt[, .N, by = .(Name, Category)]
    dt.max[, r := frank(-N, ties.method = 'random'), by = .(Name)]
    dt.max <- dt.max[r == 1, .(Name, Category)]

    dt[dt.max, on = .(Name, Category), mult = 'first']
})
#    user  system elapsed
#   2.424   0.004   2.426

Answer 3

我们可以从here修改Mode函数，然后通过filter进行分组

library(dplyr)

Mode <- function(x) {
 ux <- unique(x)
 fr1 <- tabulate(match(x, ux))
  if(n_distinct(fr1)==1) ux[sample(seq_along(fr1), 1)] else ux[which.max(fr1)]
}

d %>% 
  group_by(Name) %>%
  slice(which(Category == Mode(Category))[1])