如何总结一个组合列表

Posted 2023-02-14

【中文标题】如何总结一个组合列表

【英文标题】：How to summarize a list of combination

【发布时间】：2022-01-18 15:40:05

【问题描述】：

我有一个 2 个元素组合的列表，如下所示。

cbnl <- list(
  c("A", "B"), c("B", "A"), c("C", "D"), c("E", "D"), c("F", "G"), c("H", "I"),
  c("J", "K"), c("I", "H"), c("K", "J"), c("G", "F"), c("D", "C"), c("E", "C"),
  c("D", "E"), c("C", "E")
)

我想总结一下上面的列表。预期结果如下表所示。向量中元素的顺序在这里无关紧要。

[[1]]
[1] "A" "B"

[[2]]
[1] "C" "D" "E"

[[3]]
[1] "F" "G"

[[4]]
[1] "H" "I"

[[5]]
[1] "J" "K"

(规则 1) A, B 等价于 B, A。为了对应这个，我想我可以做到这一点。

cbnl <- unique(lapply(cbnl, function(i)  sort(i) ))

（规则 2）A，B，B，C（其中一个元素是常见的）然后取两个集合的并集。结果是A, B, C。我没有明确的好主意。

有什么有效的方法吗？

【问题讨论】：

是的，本质上是一样的。从图论的角度来看，这可以被认为是节点的连接。谢谢你的意见。

我认为Merging Listed Vectors that share Elements in R 本质上是相同的，但是 R 代码不适用于这种情况。这里的答案可能不适用于数字向量列表.....

【参考方案1】：

我知道这个答案更像是传统编程，而不是“R like”，但它解决了问题。

cbnl <- unique(lapply(cbnl, sort))

i <- 1
count <- 1
out <- list()

while (i <= length(cbnl) - 1) 
  if (sum(cbnl[[i]] %in% cbnl[[i + 1]]) == 0) 
    out[[count]] <- cbnl[[i]]
     else 
      out[[count]] <- sort(unique(c(cbnl[[i]], cbnl[[i + 1]])))
      i <- i + 1        
    
  count <- count + 1
  i <- i + 1 


out

给予，

[[1]]
[1] "A" "B"

[[2]]
[1] "C" "D" "E"

[[3]]
[1] "F" "G"

[[4]]
[1] "H" "I"

[[5]]
[1] "J" "K"

【讨论】：

太棒了。谢谢你的回答。我得到了预期的结果。

【参考方案2】：

你可以试试下面的igraph选项

library(igraph)

graph_from_data_frame(do.call(rbind, cbnl)) %>%
  components() %>%
  membership() %>%
  stack() %>%
  with(., split(as.character(ind), values))

给了

$`1`
[1] "A" "B"

$`2`
[1] "C" "E" "D"

$`3`
[1] "F" "G"

$`4`
[1] "H" "I"

$`5`
[1] "J" "K"

---

更短的

graph_from_data_frame(do.call(rbind, cbnl)) %>%
  decompose() %>%
  Map(function(x) names(V(x)), .)

给了

[[1]]
[1] "A" "B"

[[2]]
[1] "C" "E" "D"

[[3]]
[1] "F" "G"

[[4]]
[1] "H" "I"

[[5]]
[1] "J" "K"

【讨论】：

哦，这是更短的命令。预期结果出来了。

@kabocha 你可以在我的更新中找到一个较短的

谢谢。很简单的代码！！

有趣的是，几个月前我正在寻找一种算法/函数来查找以这种方式链接的记录，我记得我在谷歌中找不到合适的词（但我也没有问SO），现在我看到我应该看看图表主题：D（我确信这样的东西一定已经存在了！）。

这听起来不错。如果您能提供确切的主题名称，请告诉我。

【参考方案3】：

Base R: sorting union as FUN= in combn，然后根据唯一元素 u 部分填充矩阵并删除 duplicated 行，最后强制as.list。

u <- Reduce(union, cbnl)  ## get unique elements

res <- combn(cbnl, 2, \(x) 
  if (length(intersect(x[[1]], x[[2]])) > 0) 
    union(x[[1]], x[[2]])
   else 
    el(x)
  
, simplify=FALSE) |>
  unique() |>
  (\(x) sapply(x, \(i) replace(rep(NA, length(u)), match(i, u), i)))() |>
  (\(x) x[, !colSums(duplicated(x, MARGIN=1:2)) == nrow(x)])() |>
  (\(x) unname(lapply(as.list(as.data.frame(x)), \(x) x[!is.na(x)])))()

res
# [[1]]
# [1] "A" "B"
# 
# [[2]]
# [1] "C" "D" "E"
# 
# [[3]]
# [1] "F" "G"
# 
# [[4]]
# [1] "H" "I"
# 
# [[5]]
# [1] "J" "K"

注意：

> R.version.string
[1] "R version 4.1.2 (2021-11-01)"

【讨论】：

感谢您的回答。但未显示预期结果。我需要考虑如何以您的方式获得预期列表。

@kabocha 实际上我错过了一个案例处理，检查更新。不过，我还不确定哪条规则完全会导致您的预期结果？

非常感谢。快完成了。只需删除 C, D, D, E, C, E，因为 C, D, E 包含它们。

@kabocha 知道了，看更新！

最后，是的，我可以得到预期的结果。非常感谢。

【参考方案4】：

我从@ThomasIsCoding 中获取了一行代码，并希望证明我们可以使用我的包dedupewider 来实现这一点。

library(dedupewider)
library(purrr)
library(magrittr)

cbnl <- list(
  c("A", "B"), c("B", "A"), c("C", "D"), c("E", "D"), c("F", "G"), c("H", "I"),
  c("J", "K"), c("I", "H"), c("K", "J"), c("G", "F"), c("D", "C"), c("E", "C"),
  c("D", "E"), c("C", "E")
)

cbnl_df <- data.frame(do.call(rbind, cbnl))

result <- dedupe_wide(cbnl_df, names(cbnl_df)) # it performs deduplication by connecting elements which are linked by transitive relation

result_list <- as.list(as.data.frame(t(result)))

result_list <- map(result_list, ~ .x[!is.na(.x)]) # remove NA
result_list
#> $V1
#> [1] "A" "B"
#> 
#> $V2
#> [1] "C" "E" "D"
#> 
#> $V3
#> [1] "F" "G"
#> 
#> $V4
#> [1] "H" "I"
#> 
#> $V5
#> [1] "J" "K"

需要很多步骤，因为list是输入和输出，所以使用data.frame我们会比上面的代码少。

【讨论】：

感谢您的回答。我的原始数据是 data.table 所以你的 data.frame 方式对我来说更可取。我可以得到我预期的结果。

这样更好，因为dedupe_wide 内部使用setDT（如果需要，则在最后删除data.table 类，如果开始时不存在），所以你应该得到data.table 对象当data.table 是输入时作为返回值。

【参考方案5】：

感谢所有支持者的精彩回答。

让我通过base R发布我自己的解决方案，如下所示；

cbnl <- list(
  c("A", "B"), c("B", "A"), c("C", "D"), c("E", "D"), c("F", "G"), c("H", "I"),
  c("J", "K"), c("I", "H"), c("K", "J"), c("G", "F"), c("D", "C"), c("E", "C"),
  c("D", "E"), c("C", "E")
)

repeat 
  # Get A Count Table
  tbl <- table(unlist(cbnl))
  # No Duplicated Items Then break Out
  if (length(tbl[tbl > 1]) == 0)  break 
  # Take A First Duplicated Item And Get the Index
  idx <- which(sapply(seq_len(length(cbnl)), function(i) 
    any(cbnl[[i]] == names(tbl[tbl > 1])[1])
  ))
  # Create New vector By Taking Union
  newvec <- sort(unique(unlist(cbnl[idx])))
  # Append newvec To cbnl And Remove Original vectors
  cbnl <- c(cbnl, list(newvec))[-idx]


cbnl

结果是

[[1]]
[1] "A" "B"

[[2]]
[1] "C" "D" "E"

[[3]]
[1] "F" "G"

[[4]]
[1] "H" "I"

[[5]]
[1] "J" "K"

这里是data.table版本。

cbn <- data.table(
  item1 = c("A", "B", "C", "E", "F", "H", "J", "I", "K", "G", "D", "E", "D", "C"),
  item2 = c("B", "A", "D", "D", "G", "I", "K", "H", "J", "F", "C", "C", "E", "E")
)

repeat 
  # Get A Count Table
  tbl <- table(as.vector(as.matrix(cbn)))
  # No Duplicated Items Then break Out
  if (length(tbl[tbl > 1]) == 0)  break 
  # Take A First Duplicated Item And Get Row Numbers Where The Item Is Located
  idx <- which(cbn == names(tbl[tbl > 1])[1], arr.ind = TRUE)[, 1]
  # Create New Row By Taking Union
  newrow <- setDT(as.list(sort(unique(as.vector(as.matrix(cbn[idx]))))))
  names(newrow) <- paste0("item", seq_len(ncol(newrow)))
  # Append newrow To cbn And Remove Original Rows
  cbn <- rbindlist(l = list(cbn, newrow), use.names = TRUE, fill = TRUE)[-idx]


cbn

这个结果如下。

   item1 item2 item3
1:     A     B  <NA>
2:     C     D     E
3:     F     G  <NA>
4:     H     I  <NA>
5:     J     K  <NA>