重新编码一个向量中的值以最大化另一个向量中相同数字的对数

Question

我有下表，original_table，它是通过比较 vector_1 和 vector_2 的相同索引中数字对的频率得出的：

vector_1 <- c(5, 6, 5, 4, 6, 6, 4, 1, 6, 7, 5, 3, 3, 4, 4, 7, 7, 7, 2, 7, 2, 6, 1)
vector_2 <- c(1, 2, 1, 3, 4, 4, 4, 2, 4, 7, 2, 5, 5, 3, 3, 6, 7, 7, 6, 3, 6, 7, 2)
original_table <- table(vector_1, vector_2)
str(original_table)

        vector_2
vector_1 1 2 3 4 5 6 7
       1 0 2 0 0 0 0 0
       2 0 0 0 0 0 2 0
       3 0 0 0 0 2 0 0
       4 0 0 3 1 0 0 0
       5 2 1 0 0 0 0 0
       6 0 1 0 3 0 0 1
       7 0 0 1 0 0 1 3

我正在尝试重新编码vector_1 的值，以最大化vector_2 中具有相同索引的值的相同数字对的数量。我最终试图重新编码这些以使用Breckenridge (2000) 描述的双拆分交叉验证。

唯一的“规则”是每个值都必须重新编码为唯一值，因此1 和2 不能都重新编码为3。

我使用car::recode 或多或少地手动完成了这项工作：

vector_1 <- car::recode(vector_1, "6 = 4; 7 = 7; 4 = 3; 5 = 1; 3 = 5; 2 = 6; 1 = 2")
optimized_table <- table(vector_1, vector_2)
str(optimized_table)

        vector_2
vector_1 1 2 3 4 5 6 7
       1 2 1 0 0 0 0 0
       2 0 2 0 0 0 0 0
       3 0 0 3 1 0 0 0
       4 0 1 0 3 0 0 1
       5 0 0 0 0 2 0 0
       6 0 0 0 0 0 2 0
       7 0 0 1 0 0 1 3

这样做至少有几个问题：我目睹了它，所以我不确定这是最大化向量之间对的总数的最佳方法，而且它不容易重现一组不同的数据。我正在寻找一种方法来更好/更自动地做到这一点，但我无法轻易找到一种程序化或智能的方法来做到这一点。

Answer 1

这被称为assignment problem。解决它的一种方法是使用整数规划；你可以使用lpSolve::lp.assign:

library(lpSolve)
res <- lp.assign(-original_table)
l <- apply(res$solution > 0.5, 1, which)
# [1] 2 6 5 3 1 4 7

解决问题的先验更快的方法是使用Hungarian algorithm，在clue 包中实现：

library(clue)
res <- solve_LSAP(original_table, maximum = TRUE)
# Optimal assignment:
# 1 => 2, 2 => 6, 3 => 5, 4 => 3, 5 => 1, 6 => 4, 7 => 7
l <- as.integer(res)
# [1] 2 6 5 3 1 4 7

最后，您可以使用以下代码重新编码：

vector_1 <- l[vector_1]

Answer 2

如果两个向量中唯一值的数量不是很大，我们可以通过构造所有可能重新编码的排列，循环排列，重新编码vector_1并计算与vector_2 重叠并取最大值。这可能也无法扩展到不同的数据集，但稍作修改就可以轻松应用于两个不同的向量：

library(permute)
n = 7                 # number of unique values in vector_1 and vector_2
recodes = rbind(1:n, allPerms(n))  # calculate all possible recodes including the identity
which.max(apply(recodes, 1, function(p) sum((1:n)[match(vector_1, p)] == vector_2)))
# [1] 2943            
# this line loop through possible permutations and find out the maximum overlap of the two 
# vectors after recoding, here we used `match` instead of recode because it is easier to 
# use with vectors and will generate the same results
recodes[2943,]
# [1] 5 1 4 6 3 2 7 

将此重新编码应用于vector_1 生成：

vector_1 = (1:n)[match(vector_1, recodes[2943, ])]
table(vector_1, vector_2)

#         vector_2
# vector_1 1 2 3 4 5 6 7
#        1 2 1 0 0 0 0 0
#        2 0 2 0 0 0 0 0
#        3 0 0 3 1 0 0 0
#        4 0 1 0 3 0 0 1
#        5 0 0 0 0 2 0 0
#        6 0 0 0 0 0 2 0
#        7 0 0 1 0 0 1 3

这给出了与 OP 相同的结果，并且应该加强对所提供的重新编码进行优化的信念。

Answer 3

这是一种贪心方法：函数assign_group 接受两个向量，一个向量 1 的簇号要重新编码，一个向量的簇号为 vector_2 可用（即未分配给其他向量 1 的簇） .然后该函数计算应该将簇号v1cl 中的可用簇号映射到v2avail 中的哪个簇号。这是通过搜索同时出现最多的组来完成的。

assign_group <- function(v1, v2, v1cl, v2avail) {
    one_comparison <- function(v2cand) sum(v1==v1cl & v2==v2cand)
    counts <- sapply(v2avail, FUN=one_comparison)
    return(v2avail[which.max(counts)])
}

然后我们可以遍历vector_1的簇号，为每个簇号找到“最佳”的簇。结果，recode_map，是从vector_1 的簇号到vector_2 的簇号的映射。

v2avail <- unique(vector_2)
n <- length(v2avail)
recode_map <- rep(NA, n)
for (i in seq(n)) {
    best <- assign_group(vector_1, vector_2, i, v2avail)
    recode_map[i] <- best
    v2avail <- setdiff(v2avail, best) # don't assign the same number twice
}

重新编码的向量导致与您的问题相似的结果：

v1perm <- recode_map[vector_1]  
table(v1perm, vector_2)

此方法假定vector_1 和vector_2 由数字1:n 组成。结果通常不是最优的，它取决于组分配发生的顺序。如果首先将索引1:n 按vector_1 中的出现次数排序，然后按此顺序运行for 循环，结果可能会更好。