R中的匹配算法（二分图匹配，匈牙利算法）

Question

R中的匹配算法（二分图匹配，匈牙利算法）

12

我想知道如何在R中设置一些基本的匹配程序示例。虽然各种编程语言都有许多示例，但我还没有找到一个适用于R的好的示例。

假设我想将学生分配到项目，并考虑三种备选方案，这些方案是我在搜索此问题时发现的：

1）二分图匹配情况：我要求每个学生选择3个要参与的项目（不声明这3个项目中的任何优先顺序）。

ID  T.1 T.2 T.3 T.4 T.5 T.6 T.7
1   1   1   1   0   0   0   0
2   0   0   0   0   1   1   1
3   0   1   1   1   0   0   0
4   0   0   0   1   1   1   0
5   1   0   1   0   1   0   0
6   0   1   0   0   0   1   1
7   0   1   1   0   1   0   0

--

d.1 <- structure(list(Student.ID = 1:7, Project.1 = c(1L, 0L, 0L, 0L, 
1L, 0L, 0L), Project.2 = c(1L, 0L, 1L, 0L, 0L, 1L, 1L), Project.3 = c(1L, 
0L, 1L, 0L, 1L, 0L, 1L), Project.4 = c(0L, 0L, 1L, 1L, 0L, 0L, 
0L), Project.5 = c(0L, 1L, 0L, 1L, 1L, 0L, 1L), Project.6 = c(0L, 
1L, 0L, 1L, 0L, 1L, 0L), Project.7 = c(0L, 1L, 0L, 0L, 0L, 1L, 
0L)), .Names = c("Student.ID", "Project.1", "Project.2", "Project.3", 
"Project.4", "Project.5", "Project.6", "Project.7"), class = "data.frame", row.names = c(NA, 
-7L))

2) 匈牙利算法：我要求每个学生列出三个他们想要参与的项目，并注明这三个项目的优先级排名。据我所知，当在此情况下应用该算法时，推理是：排名越高，对学生的“成本”就越低。

ID  T.1 T.2 T.3 T.4 T.5 T.6 T.7
1   3   2   1   na  na  na  na
2   na  na  na  na  1   2   3
3   na  1   3   2   na  na  na
4   na  na  na  1   2   3   na
5   2   na  3   na  1   na  na
6   na  3   na  na  na  2   1
7   na  1   2   na  3   na  na

--

d.2 <- structure(list(Student.ID = 1:7, Project.1 = structure(c(2L, 3L, 
3L, 3L, 1L, 3L, 3L), .Label = c("2", "3", "na"), class = "factor"), 
    Project.2 = structure(c(2L, 4L, 1L, 4L, 4L, 3L, 1L), .Label = c("1", 
    "2", "3", "na"), class = "factor"), Project.3 = structure(c(1L, 
    4L, 3L, 4L, 3L, 4L, 2L), .Label = c("1", "2", "3", "na"), class = "factor"), 
    Project.4 = structure(c(3L, 3L, 2L, 1L, 3L, 3L, 3L), .Label = c("1", 
    "2", "na"), class = "factor"), Project.5 = structure(c(4L, 
    1L, 4L, 2L, 1L, 4L, 3L), .Label = c("1", "2", "3", "na"), class = "factor"), 
    Project.6 = structure(c(3L, 1L, 3L, 2L, 3L, 1L, 3L), .Label = c("2", 
    "3", "na"), class = "factor"), Project.7 = structure(c(3L, 
    2L, 3L, 3L, 3L, 1L, 3L), .Label = c("1", "3", "na"), class = "factor")), .Names = c("Student.ID", 
"Project.1", "Project.2", "Project.3", "Project.4", "Project.5", 
"Project.6", "Project.7"), class = "data.frame", row.names = c(NA, 
-7L))

3) 优化方法：这应该与（2）密切相关。然而，在我的看法中，这可能是更好/更公平的方法（至少在示例设置中）。学生们不能选择项目，他们甚至不知道项目的存在，但他们必须评价自己在某种技能集上的资质（1表示“不存在”，10表示“专业水平”）。此外，讲师已经评估了每个项目所需的技能集。除了（2）之外，第一步是计算相似性矩阵，然后运行上述优化例程。

PS: Programming Skills
SK: Statistical Knowledge
IE: Industry Experience

ID  PS  SK  IE
1   10  9   8
2   1   2   10
3   10  2   5
4   2   5   3
5   10  2   10
6   1   10  1
7   5   5   5

--

d.3a <- structure(list(Student.ID = 1:7, Programming.Skills = c(10L, 1L, 
10L, 2L, 10L, 1L, 5L), Statistical.knowlegde = c(9L, 2L, 2L, 
5L, 2L, 10L, 5L), Industry.Expertise = c(8L, 10L, 5L, 3L, 10L, 
1L, 5L)), .Names = c("Student.ID", "Programming.Skills", "Statistical.knowlegde", 
"Industry.Expertise"), class = "data.frame", row.names = c(NA, 
-7L))

--

T: Topic ID
PS: Programming Skills
SK: Statistical Knowledge
IE: Industry Experience

T  PS   SK  IE
1   10  5   1
2   1   1   5
3   10  10  10
4   2   8   3
5   4   3   2
6   1   1   1
7   5   7   2

--

d.3b <- structure(list(Project.ID = 1:7, Programming.Skills = c(10L, 
1L, 10L, 2L, 4L, 1L, 5L), Statistical.Knowlegde = c(5L, 1L, 10L, 
8L, 3L, 1L, 7L), Industry.Expertise = c(1L, 5L, 10L, 3L, 2L, 
1L, 2L)), .Names = c("Project.ID", "Programming.Skills", "Statistical.Knowlegde", 
"Industry.Expertise"), class = "data.frame", row.names = c(NA, 
-7L))

我很乐意在R中实施这3种方法时提供任何帮助。谢谢。

更新：以下问题似乎是相关的，但没有一个展示如何在R中解决： https://math.stackexchange.com/questions/132829/group-membership-assignment-by-preferences-optimization-problem https://superuser.com/questions/467577/using-optimization-to-assign-by-preference

- majom

R语言是专为统计向量处理而设计的。我不会期望它在这方面或其他许多方面都是理想的选择。因此，通过快速的谷歌搜索，您可以找到大量关于如何从R调用其他语言的信息。一种非常简单的方法是通过system()让R调用其他程序，例如在http://darrenjw.wordpress.com/2010/12/30/calling-c-code-from-r/中所述-尽管对于这种方法来说，其他程序写成什么并不重要，因此C几乎可以是任何东西。 - mcdowella

由于这些似乎是非常基本的技术，我想知道R是否也通过例如optmatch包或clue包（即solve_LSAP()）提供此功能。 - majom

您可以使用solve_LSAP()来解决这些问题，您需要正确获取约束条件和成本函数。您甚至可能想要查看优化包optimx。 - jackStinger

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Mark Miller · Accepted Answer

以下是使用二分图匹配和匈牙利算法的可能解决方案。

使用二分图匹配的我提出的解决方案可能不是您想要的。以下代码只是随机采样指定次数，之后至少会找到一个解决方案。这可能需要大量迭代和长时间来解决大问题。以下代码在200次迭代内找到了三个解决方案来解决您的示例问题。

matrix1 <- matrix(c( 1,   1,   1,  NA,  NA,  NA,  NA,
                    NA,  NA,  NA,  NA,   1,   1,   1,
                    NA,   1,   1,   1,  NA,  NA,  NA,
                    NA,  NA,  NA,   1,   1,   1,  NA,
                     1,  NA,   1,  NA,   1,  NA,  NA,
                    NA,   1,  NA,  NA,  NA,   1,   1,
                    NA,   1,   1,  NA,   1,  NA,  NA), nrow=7, byrow=TRUE)

set.seed(1234)

iters <- 200

my.match <- matrix(NA, nrow=iters, ncol=ncol(matrix1))

for(i in 1:iters) {

     for(j in 1:nrow(matrix1)) {

          my.match[i,j] <- sample(which(matrix1[j,] == 1), 1)

     }
}

n.unique <- apply(my.match, 1, function(x) length(unique(x)))

my.match[n.unique==ncol(matrix1),]

#      [,1] [,2] [,3] [,4] [,5] [,6] [,7]
# [1,]    3    7    4    6    1    2    5
# [2,]    1    7    4    5    3    6    2
# [3,]    3    5    4    6    1    7    2

这里是使用clue包和solve_LSAP()的匈牙利算法代码，正如@jackStinger建议的那样。为了使其工作，我不得不替换缺失的观察值，并任意将它们替换为4。第5个人没有得到他们的首选项，第7个人没有得到他们三个选择中的任何一个。

library(clue)

matrix1 <- matrix(c( 3,   2,   1,   4,   4,   4,   4,
                     4,   4,   4,   4,   1,   2,   3,
                     4,   1,   3,   2,   4,   4,   4,
                     4,   4,   4,   1,   2,   3,   4,
                     2,   4,   3,   4,   1,   4,   4,
                     4,   3,   4,   4,   4,   2,   1,
                     4,   1,   2,   4,   3,   4,   4), nrow=7, byrow=TRUE)

matrix1

solve_LSAP(matrix1, maximum = FALSE)

# Optimal assignment:
# 1 => 3, 2 => 5, 3 => 2, 4 => 4, 5 => 1, 6 => 7, 7 => 6

以下是关于匈牙利算法的演示网站链接：http://www.wikihow.com/Use-the-Hungarian-Algorithm 编辑：2014年6月5日

这里是我对第三种场景进行优化的第一次尝试。我随机分配每个学生到一个项目，然后计算该任务集的成本。成本是通过找到学生技能和项目所需技能之间的差异来计算的。这些差异的绝对值被求和以给出七个任务的总成本。

以下我将这个过程重复了10,000次，并确定其中哪一个分配结果使成本最低。

另一种方法是对所有可能的学生-项目分配进行详尽搜索。

无论是随机搜索还是详尽搜索都不太可能是您想要的。但是，前者将提供近似最优解，而后者将提供精确最优解。

我可能会稍后回到这个问题。

students <- matrix(c(10,   9,   8,
                      1,   2,  10,
                     10,   2,   5,
                      2,   5,   3,
                     10,   2,  10,
                      1,  10,   1,
                      5,   5,   5), nrow=7, ncol=3, byrow=TRUE)

projects <- matrix(c(10,   5,    1,
                      1,   1,    5,
                     10,  10,   10,
                      2,   8,    3,
                      4,   3,    2,
                      1,   1,    1,
                      5,   7,    2), nrow=7, ncol=3, byrow=TRUE)

iters <- 10000

# col = student, cell = project
assignments <- matrix(NA, nrow=iters, ncol=nrow(students))

for(i in 1:iters) {
      assignments[i,1:7] <- sample(7,7,replace=FALSE)
}

cost <- matrix(NA, nrow=iters, ncol=nrow(students))

for(i in 1:iters) {

     for(j in 1:nrow(students)) {

          student <- j
          project <- assignments[i,student]

          student.cost <- rep(NA,3)

          for(k in 1:3) {     

               student.cost[k] <- abs(students[student,k] - projects[project,k])

          } 

          cost[i,j] <- sum(student.cost)

     }

}


total.costs <- rowSums(cost)

assignment.costs <- cbind(assignments, total.costs)
head(assignment.costs)

assignment.costs[assignment.costs[,8]==min(assignment.costs[,8]),]

#                    total.costs
# [1,] 3 2 1 4 5 6 7          48
# [2,] 3 2 1 6 5 4 7          48
# [3,] 3 2 1 6 5 4 7          48

# student 1, project 3, cost = 3
# student 2, project 2, cost = 6
# student 3, project 1, cost = 7
# student 4, project 4, cost = 3
# student 5, project 5, cost = 15
# student 6, project 6, cost = 9
# student 7, project 7, cost = 5

3+6+7+3+15+9+5

# [1] 48

编辑：2014年6月6日

这里是详尽的搜索结果。将项目分配给七名学生只有5040种可能的方式。该搜索返回四个最优解：

students <- matrix(c(10,   9,   8,
                      1,   2,  10,
                     10,   2,   5,
                      2,   5,   3,
                     10,   2,  10,
                      1,  10,   1,
                      5,   5,   5), nrow=7, ncol=3, byrow=TRUE)

projects <- matrix(c(10,   5,    1,
                      1,   1,    5,
                     10,  10,   10,
                      2,   8,    3,
                      4,   3,    2,
                      1,   1,    1,
                      5,   7,    2), nrow=7, ncol=3, byrow=TRUE)

library(combinat)

n <- nrow(students)

assignments <- permn(1:n)
assignments <- do.call(rbind, assignments)
dim(assignments)

# column of assignments = student
# row of assignments = iteration
# cell of assignments = project

cost <- matrix(NA, nrow=nrow(assignments), ncol=n)

for(i in 1:(nrow(assignments))) {
     for(student in 1:n) {

          project      <- assignments[i,student]
          student.cost <- rep(NA,3)

          for(k in 1:3) {     
               student.cost[k] <- abs(students[student,k] - projects[project,k])
          } 

          cost[i,student] <- sum(student.cost)
     }
}


total.costs <- rowSums(cost)

assignment.costs <- cbind(assignments, total.costs)
head(assignment.costs)

assignment.costs[assignment.costs[,(n+1)]==min(assignment.costs[,(n+1)]),]

                   total.costs
[1,] 3 2 5 4 1 6 7          48
[2,] 3 2 5 6 1 4 7          48
[3,] 3 2 1 6 5 4 7          48
[4,] 3 2 1 4 5 6 7          48