如何用R模拟婚姻市场上的匹配问题
介绍
这学期我在做助教的时候接触到了一个很有趣的问题，而且可以用简单的R代码来解决，所以想在这里分享给大家。
这个问题是这样的：
到底怎么找对象？
俗话说书中自有颜如玉，没想到学好R语言，连人生大事都顺带解决了。
开玩笑，其实我今天要谈的是一个很经典的『稳定婚姻问题』，最早来源于David Gale和Lloyd Shapley*的论文 College Admissions and the Stability of Marriage。
问题
假定有N个男生，M个女生，每个人都对异性有着自己的排序。如何设计一个结婚匹配机制，从而使所有人在婚后都不会出轨*？
*注：出轨的定义：A男觉得b女优于自己现任妻子a女，b女也认为A男优于自己现任丈夫B男，此时A男和b女即出轨哎呀，这是啥问题啊，怎么让我想到集体相亲节目？我好像闻到了一股八卦的气息。
言归正传，为了理解题目，不妨拿具体数字举个例子。
假设社会里有10个男生，8个妹子，分别编号。大致来说1号最受欢迎，2号其次，依次类推，不过我也在排序中加入了一些随机性，允许每个人的偏好有所不同。
男生对妹子的排序如下：
横行代表男生。比如说我们看第一行，就是说对于1号男嘉宾来说，1号女嘉宾排第二，2号女嘉宾排第三，3号女嘉宾排第一，4号女嘉宾排第四，5号女嘉宾排第六，等等等等。
观察：
我生成的这个例子里，很多男生都最喜欢1、2、3号女生。
不过也有特立独行的10号男生，最喜欢4号女生。我们看看他们最后能不能在一起。
相应地，姑娘们对于男生也有自己的排序：
观察：
1号男生估计是帅且身材好，最受各位妹子青睐。2号、3号也不错。
5号女生碰巧最喜欢5号男生。
可怜的10号男生，经常排名垫底，最好也就是排个第八名。
下面问题来了，我们如何把这些青年男女匹配在一起？
首先我们无情地排除了同性恋的可能性，也就是说最后只有8对男女牵手成功。至于剩下的两个男生要不要在一起，本文不进行讨论，他们的命运由读者自行安排。
其次，我们要假设男生主动追求女生。这个假设是为了写算法方便，我们也可以假设是女生主动，在这个例子中结果是一样的。如果参与者人数增加，那么结果则不一定相同。
最后，在介绍算法之前，大家要意识这个问题的复杂性以及特殊性。为了确定没有更好的结婚人选，主动的一方需要不断试探，搜索大量的信息，而这在生活中是不现实的。我们假设的是一个理想的情况。打个比方，就好像把所有人困在同一个房间里，不完成稳定的匹配，谁也不许走。所以，把这个例子当成一个有趣的数学模型，作为现实生活的一个投影，也就够了。
（对吧，比如相亲会有下面这种效率就不错了）
咳咳，跑偏了，赶快回到学术讨论。
讨论算法的部分可能有点枯燥。只对牵手结果感兴趣的读者请跳过本节！
算法
Gale-Shapley的算法是这样的（Pseudo-code)：
function stableMatching {
Initialize all m ∈ M and w ∈ W to free
while ∃ free man m who still has a woman w to propose to {
w = first woman on m’s list to whom m has not yet proposed
if w is free
(m, w) become engaged
else some pair (m', w) already exists
if w prefers m to m'
m' becomes free
(m, w) become engaged
else
(m', w) remain engaged
}
}等一下，上面说了个啥？
让我翻译成人话：
对于每一个单身的男生m，向他尚未求婚过的女性中，排名最高那一位（记作w）求婚
如果w单身，二人暂时订婚
如果w已经和其他男生m'订婚，w会选择对她排名更高的一位男士，拒绝另一位
被拒绝的男士重新回到单身。
重复上述过程，直到匹配稳定
其实算法很简单，不过，在这个环环相扣的故事里，充满了狗血剧情。
比如他喜欢她，但是她已经与人订婚，他只能横刀夺爱；
或者他久被拒绝，已经失去了人生希望，突然在下一个女生的怀抱中寻到真爱；
或者她朝三暮四，不断拒绝过去的感情，只因为了寻找更好的另一半...
人生百态，尽在其中！
当然，可能只是我比较能想象吧【笑】
哦，对了，既然题目叫『如何用R模拟婚姻市场的匹配问题』，那就不能忘了放上R代码是吧。为了行文流畅，我把代码放到了文后，请感兴趣的读者自行参考。
结果
终于到了大家期待的牵手结果阶段！让我们看看谁和谁在一起了！【八卦脸】
整理结果如下：
每列分别代表：男生编号，女生编号，女生在男生心中的排名，男生在女生心中的排名。
我们观察到一些结果：
1号男神和3号女神，2号男神和1号女神在一起了，而且都是对方心中的首选。恭喜他们！
3号男生其实也不差，可是因为1、2号男生选走了他的首选，他只能选择了排名第三的6号女生。（当然6号女生是很开心的啦，3号男正好是她的首选）
9号和10号最后还是单身，所以从上表中略去了。抱歉。
虽然处于被动地位，但女生最终对于自己配偶的满意程度普遍高于男性的满意程度，尤其对于5-8号男生及其配偶来说。这是因为女生处于相对少数。
感想
做完这个练习，我也多少产生了一些感触：
Gale-Shapley算法真的很神奇，可以解决一系列类似的问题，比如（但不限于）
美国大学应该如何招到最好的申请者？
如何给学生分配室友？
如何给病人安排病房？
Matching是一个很成熟的研究领域，感兴趣的读者可以继续阅读参考文献中的论文。
我刚才发现，已经有人写出专门应用这个算法的R package了：
R package: matchingMarkets
看来网上果然是人才济济。我不是计算机专业出身，只是为了个人爱好才写这篇文章。欢迎懂行的各位与我交流！
最后。
你或许会觉得，你的另一半不是你最心仪的那个人。
但是在他/她眼中，你的爱可能胜过一切。
珍惜眼前人。
参考文献
Gale, D.; Shapley, L. S. 1962. College Admissions and the Stability of Marriage. American Mathematical Monthly 69: 9–14.
D. G. McVitie and L. B. Wilson. 1971. The stable marriage problem. Commun. ACM 14, 7 (July 1971), 486-490.
Roth, Alvin E.. 1982. “The Economics of Matching: Stability and Incentives”. Mathematics of Operations Research 7 (4). INFORMS: 617–28.
Dubins, L. E., and D. A. Freedman. 1981. “Machiavelli and the Gale-shapley Algorithm”. The American Mathematical Monthly 88 (7). Mathematical Association of America: 485–94.
Becker, Gary. "A Theory of Social Interactions." (1974).
Stable marriage problem -- Wikipedia
附录
R 代码：
# Fix randomize resultset.seed(907) # Number of AgentsnMales <- 10nFemales <- 8# Match utility of agents# each column represents the utility of the agent,# when matched with the agent in the corresponding rowutilMale <- t(replicate(nMales,seq(100,1,length =nFemales)+100*runif(nFemales)))utilFemale <- t(replicate(nFemales,seq(100,1,length =nMales)+100*runif(nMales)))# Match preference order of agentsrankMale <- t(sapply(1:nMales,function(x) order(utilMale[x,],decreasing=T)))rankFemale <- t(sapply(1:nFemales,function(x) order(utilFemale[x,],decreasing=T)))# Match FunctionDeferredAcceptanceAlgorithm <- function(males, females, females_propose = FALSE){ if(females_propose){ nProposers <- nrow(females) proposers <- females nAcceptors <- nrow(males) acceptors <- males } else { nProposers <- nrow(males) proposers <- males nAcceptors <- nrow(females) acceptors <- females } matches = matrix(0,nProposers,nAcceptors) prev_matches = matrix(1,nProposers,nAcceptors) #Iterates until matches are stable while (all((matches==prev_matches))==F) { prev_matches = matches #Saves previous matches for (m in 1:nProposers) #Loops over all proposers { #Loops over mates in order of preference for (mate in order(proposers[m,])) { # if neither are engaged if (sum(matches[m,])==0 & sum(matches[,mate])==0){ matches[m,mate]=1 # They get matched } # if woman is engaged if (sum(matches[m,])==0 & sum(matches[,mate])>0) { # identify her current fiance's index otherProp = match(1,matches[,mate]) # check if proposal is better than her current match if (acceptors[mate,m] < acceptors[mate,otherProp]) { matches[otherProp,mate] = 0 # If so other guy gets dumped matches[m,mate] = 1 # And current guy gets matched } } } } } if(females_propose){ matches <- t(matches) } return(matches) # Return matches}output <- DeferredAcceptanceAlgorithm(rankMale,rankFemale)list <- cbind(1:10,sapply(1:10, function(x) which.max(output[x,]) ))F_in_M <- sapply(1:8, function(i) rankMale[list[i,1],list[i,2]])M_in_F <- sapply(1:8, function(i) rankFemale[list[i,2],list[i,1]])list <- data.frame(cbind(list[1:8,],F_in_M,M_in_F))names(list) <- c("Male","Female", "F_in_M","M_in_F")xtable(rankMale)xtable(rankFemale)xtable(output)xtable(list)作者：李佳飞
知乎专栏：知叶堂
https://zhuanlan.zhihu.com/p/25446637
微信回复关键字即可学习
回复 R R语言快速入门免费视频
回复 统计 统计方法及其在R中的实现
回复 用户画像 民生银行客户画像搭建与应用
回复 大数据 大数据系列免费视频教程
回复 可视化 利用R语言做数据可视化
回复 数据挖掘 数据挖掘算法原理解释与应用
回复 机器学习 R&Python机器学习入门