R语言优化：非0簇标签频次统计及占比计算函数的高效实现

我有聚类算法输出的簇编号向量cluster（取值0到n），以及标签值为0和1的向量label，需要完成以下操作：

• 排除簇0，统计其余每个簇中标签0和1的出现次数
• 计算每个簇中标签1的占比
• 按标签1的占比降序排序结果

我自己写了cluster_metrics函数实现功能，但觉得不符合R语言的惯用风格，想找更高效的实现方式。

测试数据 #

聚类结果向量 #

set.seed(1)
cluster <- sample(0:5, 100, replace = T)
cluster
  [1] 0 3 0 1 4 2 5 1 2 2 0 4 4 1 5 5 1 0 4 4 0 0 5 4 4 1 1 5 0 3 0 3 2 5 1 1 5 3 3
 [40] 3 1 3 0 5 0 3 0 5 1 2 1 5 5 1 4 1 5 5 5 0 2 2 5 3 5 2 0 3 4 0 0 5 3 4 4 3 5 4
 [79] 3 3 0 4 4 5 0 0 2 5 1 1 2 5 1 3 2 4 1 1 0 2

标签向量 #

label <- sample(0:1, 100, replace = T)
label
  [1] 0 1 0 1 0 1 1 1 0 1 0 0 1 0 1 1 1 0 0 1 0 0 0 0 1 1 1 1 1 0 0 0 1 0 0 1 0 0 1
 [40] 0 0 1 0 0 1 1 1 1 0 1 0 0 0 0 0 1 0 1 0 0 1 0 1 1 1 0 1 0 0 1 1 0 1 1 1 0 0 1
 [79] 0 0 0 0 1 0 0 0 1 1 0 1 1 1 1 1 0 1 0 0 1 0

期望输出 #

cluster_metrics(cluster,label)
     clust sum_1 sum_0   percent
[1,]     2     7     5 0.5833333
[2,]     4     8     7 0.5333333
[3,]     1     9     9 0.5000000
[4,]     5    10    11 0.4761905
[5,]     3     7     8 0.4666667

现有实现函数 #

cluster_metrics <- function(clust, label){
  mx <-  max(clust)
  res <- matrix(NA,ncol=4,nrow=mx)
  colnames(res) <- c("clust","sum_1","sum_0","percent")
  for(i in 1:mx){
    id <- clust==i
    s1 <- sum(label[id]==1)
    s0 <- sum(label[id]==0)
    res[i,] <- c(i, s1, s0, s1/(s1+s0))
  }
  res[order(res[,"percent"],decreasing = T),]
}

性能测试结果 #

Unit: microseconds
                              expr       min        lq       mean     median         uq       max
             my_fu(cluster, label)   185.305   229.208   254.8142   251.1595   275.3915   382.584
           PGSA_fu(cluster, label)   909.419  1003.496  1272.7706  1133.7810  1287.4410 10025.276
         jay.sf_fu(cluster, label)  6152.120  6437.774  7196.9997  6787.0025  7515.1085 16177.966
 ThomasIsCoding_fu(cluster, label)  1167.705  1286.871  1438.5756  1385.2250  1488.1410  3471.757
  Jilber_Urbina_fu(cluster, label) 17980.839 19044.489 21186.8975 19953.9080 21575.1820 51005.578
 neval
   100
   100
   100
   100
   100

更符合R风格的高效实现 #

方案1：Base R（无额外依赖） #

利用向量化操作替代循环，更贴合R语言惯用逻辑：

cluster_metrics_base <- function(clust, label) {
  # 过滤簇0并整理数据
  df <- data.frame(clust = clust, label = label) |>
    subset(clust != 0)
  
  # 交叉统计各簇标签分布
  tab <- table(df$clust, df$label)
  # 转换为结果数据框并计算占比
  res <- data.frame(
    clust = as.integer(rownames(tab)),
    sum_1 = tab[, "1"],
    sum_0 = tab[, "0"],
    percent = tab[, "1"] / rowSums(tab)
  )
  
  # 降序排序并重置行名
  res <- res[order(-res$percent), ]
  rownames(res) <- NULL
  res
}

方案2：dplyr（简洁易读） #

借助tidyverse工具链，代码可读性更强：

library(dplyr)
library(tidyr)

cluster_metrics_dplyr <- function(clust, label) {
  tibble(clust = clust, label = label) |>
    filter(clust != 0) |>
    count(clust, label) |>
    pivot_wider(names_from = label, values_from = n, names_prefix = "sum_", values_fill = 0) |>
    mutate(percent = sum_1 / (sum_1 + sum_0)) |>
    arrange(desc(percent))
}

方案3：data.table（大数据场景最优） #

适合处理超大规模数据集，性能优势明显：

library(data.table)

cluster_metrics_dt <- function(clust, label) {
  dt <- data.table(clust = clust, label = label)[clust != 0]
  dt[, .(sum_1 = sum(label == 1), sum_0 = sum(label == 0)), by = clust][
    , percent := sum_1 / (sum_1 + sum_0)][
      order(-percent)]
}

内容的提问来源于stack exchange，提问作者mr.T