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)描述的双拆分交叉验证。

唯一的规则＆＃34;是每个值都必须使用唯一值进行重新编码，因此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

这样做至少有几个问题：我对它进行了观察，所以我不确定这是最大化矢量之间的对数总数的最佳方法，它是＆＃39 ; s不容易用不同的数据集重现。我正在寻找一种更好/更自动地做到这一点的方法，但我无法轻易找到一种程序化或智能的方法。

Answer 1

这被称为assignment problem。解决它的一种方法是使用整数编程;你可以使用<?= \Yii::$app->user->name ?> <?= \Yii::$app->user->username ?>：

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

Answer 2

这是一种贪婪的方法：函数assign_group获取两个向量，一个要重新编码的向量1的簇数和一个可用的向量_的簇数的向量（即未分配给其他簇的vector_1）。该函数计算应该映射v2avail簇号v1cl中可用簇的哪个簇号。这是通过搜索具有最多同时发生的组来完成的。

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循环，结果可能会更好。

Answer 3

如果两个向量中的唯一值的数量不是很大，我们可以通过构造可能的重新编码的所有排列，循环遍历排列，重新编码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相同的结果，并且应该加强对所提供的重新编码进行优化的信念。

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

3 个答案: