如何有效地将对划分为簇，以便每个簇包含给定集合的所有条目

Question

假设我们有一组v偶数基数，例如 ，v <- 1:6和一个由 的df条目组成的data.frame v，它是由每列中每个元素的固定出现次数定义的v，即k，例如

k <- 2
x <- rep(v, each = k)
df <- data.frame(A = x, B = c(tail(x, -(k + 1)), head(x, k + 1)))

显示为

> df
   A B
1  1 2
2  1 3
3  2 3
4  2 4
5  3 4
6  3 5
7  4 5
8  4 6
9  5 6
10 5 1
11 6 1
12 6 2

1:6两列中的出现次数分别是2

> table(df$A)

1 2 3 4 5 6
2 2 2 2 2 2

> table(df$B)

1 2 3 4 5 6
2 2 2 2 2 2 

目标和预期产出

在 中df，每一行代表一个“对”，并且不存在重复的“对”。我想知道如何将这些对分成簇，使得每个簇都是最小且完整的，即每个簇包含来自 的所有值v，没有任何重复的条目。

由于 的基数v是length(v)，并且 中每个条目的出现次数df实际上是2*k，因此通过 的“理想”分割得到的簇数df应该是2*k*length(v)/length(v) == 2*k。换句话说，簇的数量k仅由 定义2*k。

例如，df可以分为4如下所示的簇，其中可以实现“完整性”属性

[[1]]
  A B
1 1 2
5 3 4
9 5 6

[[2]]
   A B
2  1 3
7  4 5
12 6 2

[[3]]
   A B
3  2 3
8  4 6
10 5 1

[[4]]
   A B
4  2 4
6  3 5
11 6 1

请注意，上面的输出只是有效实例之一，应该还有其他候选实例进行聚类。

问题

一种可能的解决方案是使用蒙特卡罗模拟，并在随机聚类满足所有约束的情况下迭代地保留有效的聚类结果。代码可能如下所示

out <- c()
repeat {
  if (nrow(df) == 0) {
    break
  }
  repeat {
    k <- sample.int(nrow(df), length(v) / 2)
    if (!length(setdiff(v, unlist(df[k, ])))) {
      out <- c(out, list(df[k, ]))
      df <- df[-k, ]
      break
    }
  }
}

有时可以给出所需的输出，例如

> out
[[1]]
   A B
6  3 5
11 6 1
4  2 4

[[2]]
   A B
2  1 3
7  4 5
12 6 2

[[3]]
   A B
8  4 6
3  2 3
10 5 1

[[4]]
  A B
1 1 2
9 5 6
5 3 4

然而，这种方法有一个主要问题，例如效率低下：如果集合的v基数很大，蒙特卡罗模拟的空间就会呈指数级增长，这会大大减慢寻找有效解决方案的过程。

---

我想知道是否有一个稳定且更有效的方法来解决此类问题。我认为回溯应该有效，但我相信一定有其他方法可以以更优雅的方式实现它。

期待多样化且有趣的解决方案。提前赞赏！

Answer 1

我不确定我是否完全遵循所需的行为，因此我建议进一步测试此解决方案。这个想法是：

1. 创建一个图，其中每个顶点都是一行df，并且如果两个顶点没有共同元素，则将它们连接起来。
2. 找到最大的团（可以组合在一起而不产生重复的最大行集合）。
3. 根据步骤 2 的结果解决集合覆盖问题，以便在输出中表示每一行。

library(Rfast) # for `rowTabulate` and `rowMaxs`
library(adagio) # for `setcover`
library(igraph) # for `max_cliques`

f <- function(df) {
  v <- unique(unlist(df))
  pairs <- combn(nrow(df), 2)
  n <- choose(nrow(df), 2)
  y <- matrix(match(unlist(df[combn(nrow(df), 2),]), v), 2*n, 2, 1)
  y <- rowTabulate(cbind(y[1:n,], y[(n + 1):(2*n),]), length(v))
  mode(y) <- "numeric"
  g <- graph_from_data_frame(as.data.frame(t(pairs[,rowMaxs(y, TRUE) == 1])),
                             FALSE)
  cl <- lapply(max_cliques(g, length(v)/2), \(x) as.integer(names(x)))
  m <- matrix(0L, length(cl), nrow(df))
  m[cbind(rep(1:length(cl), each = length(v)/2), unlist(cl))] <- 1L
  lapply(cl[setcover(m)$sets], \(x) df[x,])
}

df根据问题进行测试：

f(df)
#> [[1]]
#>    A B
#> 11 6 1
#> 6  3 5
#> 4  2 4
#> 
#> [[2]]
#>    A B
#> 2  1 3
#> 12 6 2
#> 7  4 5
#> 
#> [[3]]
#>    A B
#> 3  2 3
#> 8  4 6
#> 10 5 1
#> 
#> [[4]]
#>   A B
#> 5 3 4
#> 1 1 2
#> 9 5 6