select 所有组合中最好的梳子 data.table r

Question

假设有几个公司组合产生某个最佳值，如何高效地 select 每个公司只出现一次的唯一最佳组合 data.table 方式？

示例数据：

require(data.table)
set.seed(1234)
allcombs <- data.table(val=sample(1:20,15), t(combn(LETTERS[1:6], 2)))
setnames(allcombs, paste0("V",1:2), paste0("firm",1:2))
copy_sets = copy(allcombs)

allcombs
    val firm1 firm2
 1:  16     A     B
 2:   5     A     C
 3:  12     A     D
 4:  15     A     E
 5:   9     A     F
 6:  19     B     C
 7:   6     B     D
 8:   4     B     E
 9:   2     B     F
10:   7     C     D
11:  14     C     E
12:  10     C     F
13:  11     D     E
14:  20     D     F
15:  13     E     F

我可以用一个循环来做到这一点：

all_elements = unique(c(allcombs$firm1, allcombs$firm2))
selected_pairs = data.table()
while (length(all_elements) > 0){
  selected_pairs <- rbind(selected_pairs, allcombs[allcombs[firm1 == all_elements[1] | firm2 == all_elements[1], .I[which.max(val)]]])
  all_elements <- setdiff(all_elements, unlist(allcombs[allcombs[firm1 == all_elements[1] | firm2 == all_elements[1], .I[which.max(val)]],.(firm1,firm2)]))
  allcombs <- allcombs[firm1 %in% all_elements & firm2 %in% all_elements]
}

这就是我想要的：

selected_pairs
   val firm1 firm2
1:  16     A     B
2:  14     C     E
3:  20     D     F

任何帮助表示赞赏！

Answer 1

如果我理解正确，OP 想要 select 每个公司只出现一次的独特最佳组合。

下面的代码选择具有最高val的组合，将包含firm1或firm2的所有其他行标记为完成，并迭代地继续剩余的行，直到完成所有行。 簿记是通过引用更新rank列来完成的，即不进行复制。

d <- copy(allcombs)
setorder(d, -val)
d[, rank := NA_integer_]
r = 0L
remain <- d[, .I]
while (length(remain) > 0) {
  r <- r + 1L
  idx <- remain[d[remain, which.max(val)]]
  d[idx, rank := r]
  lut <- d[idx, .(firm = c(firm1, firm2), rank = NA_integer_)]
  d[lut, on = c("firm1==firm", "rank"), rank := 0]
  d[lut, on = c("firm2==firm", "rank"), rank := 0]
  remain <- d[, .I[is.na(rank)]]
}
d[rank > 0]

 val firm1 firm2 rank <int> <char> <char> <int> 1: 20 DF 1 2: 19 B C 2 3: 15 AE 3

请注意，此处的结果与 OP 的结果不同，因为 data.table 是按递减val排序的，而 OP 的代码按照公司名称在firm1和firm2中出现的顺序遍历行。

我发现这是武断的而不是决定性的。 OP 的方法将 select 仅在当前firm1实例的组合中是次优的，而不是所有剩余行的整体最优。

---

编辑 2

下面是上述代码的简化版本，它使用了一个额外的行 id rn列而不是remain向量：

d <- copy(allcombs)
d[, rank := NA_integer_] # append bookkeeping column
d[, rn := .I] # append row id
r = 0L
while (any(is.na(d$rank))) {
  r <- r + 1L
  idx <- d[is.na(rank), rn[which.max(val)]]
  d[idx, rank := r]
  lut <- d[idx, .(firm = c(firm1, firm2), rank = NA_integer_)]
  d[lut, on = c("firm1==firm", "rank"), rank := 0L]
  d[lut, on = c("firm2==firm", "rank"), rank := 0L]
}
d[rank > 0]

---

编辑 1

出于好奇，我试图重现 OP 的预期结果。 因此，这是上面代码的一个变体，它循环遍历唯一的公司名称：

d <- copy(allcombs)
firms <- d[, unique(c(firm1, firm2))]
# firms <- rev(d[, unique(c(firm1, firm2))])
d[, rank := NA_integer_]
d[, rn := .I] # append row id
r = 0L
for (f in firms) {
  r <- r + 1L
  idx <- d[is.na(rank) & (firm1 == f | firm2 == f), rn[which.max(val)]]
  d[idx, rank := r]
  lut <- d[idx, .(firm = c(firm1, firm2), rank = NA_integer_)]
  d[lut, on = c("firm1==firm", "rank"), rank := 0L]
  d[lut, on = c("firm2==firm", "rank"), rank := 0L]
  if (!any(is.na(d$rank))) break
}
d[rank > 0]

     val  firm1  firm2  rank    rn
1:    16      A      B     1     1
2:    14      C      E     3    11
3:    20      D      F     4    14

如上所述，结果可能取决于公司名称在firm1和firm2中出现的顺序。

这可以通过颠倒公司名称的顺序来证明

firms <- rev(d[, unique(c(firm1, firm2))])

现在，代码返回

     val  firm1  firm2  rank    rn
1:    15      A      E     2     4
2:    19      B      C     4     6
3:    20      D      F     1    14

簿记列没有被移除以进行演示。