如何用R模拟婚姻市场上的匹配问题

介绍

这学期我在做助教的时候接触到了一个很有趣的问题，而且可以用简单的R代码来解决，所以想在这里分享给大家。

这个问题是这样的：

到底怎么找对象？

俗话说书中自有颜如玉，没想到学好R语言，连人生大事都顺带解决了。

开玩笑，其实我今天要谈的是一个很经典的『稳定婚姻问题』，最早来源于David Gale和Lloyd *的论文 and the of 。

*注：没错，这就是三月份刚刚去世的那位，诺贝尔经济学奖得主。虽然他一直认为自己是一个数学家，但毋庸置疑地说，他在经济学，尤其是博弈论领域，做出了无可比拟的贡献。

问题

假定有N个男生，M个女生，每个人都对异性有着自己的排序。如何设计一个结婚匹配机制，从而使所有人在婚后都不会出轨*？

*注：出轨的定义：A男觉得b女优于自己现任妻子a女，b女也认为A男优于自己现任丈夫B男，此时A男和b女即出轨

哎呀，这是啥问题啊，怎么让我想到集体相亲节目？我好像闻到了一股八卦的气息。

言归正传，为了理解题目，不妨拿具体数字举个例子。

假设社会里有10个男生，8个妹子，分别编号。大致来说1号最受欢迎，2号其次，依次类推，不过我也在排序中加入了一些随机性，允许每个人的偏好有所不同。

男生对妹子的排序如下：

横行代表男生。比如说我们看第一行，就是说对于1号男嘉宾来说，1号女嘉宾排第二，2号女嘉宾排第三，3号女嘉宾排第一，4号女嘉宾排第四，5号女嘉宾排第六，等等等等。

观察：

相应地，姑娘们对于男生也有自己的排序：

观察：

下面问题来了，我们如何把这些青年男女匹配在一起？

首先我们无情地排除了同性恋的可能性，也就是说最后只有8对男女牵手成功。至于剩下的两个男生要不要在一起，本文不进行讨论，他们的命运由读者自行安排。

其次，我们要假设男生主动追求女生。这个假设是为了写算法方便，我们也可以假设是女生主动，在这个例子中结果是一样的。如果参与者人数增加，那么结果则不一定相同。

最后，在介绍算法之前，大家要意识这个问题的复杂性以及特殊性。为了确定没有更好的结婚人选，主动的一方需要不断试探，搜索大量的信息，而这在生活中是不现实的。我们假设的是一个理想的情况。打个比方，就好像把所有人困在同一个房间里，不完成稳定的匹配，谁也不许走。所以，把这个例子当成一个有趣的数学模型，作为现实生活的一个投影，也就够了。

（对吧，比如相亲会有下面这种效率就不错了）

咳咳，跑偏了，赶快回到学术讨论。

讨论算法的部分可能有点枯燥。只对牵手结果感兴趣的读者请跳过本节！

算法

Gale-的算法是这样的（-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
    }
}

等一下，上面说了个啥？

让我翻译成人话：

重复上述过程，直到匹配稳定

其实算法很简单，不过，在这个环环相扣的故事里，充满了狗血剧情。

人生百态，尽在其中！

当然，可能只是我比较能想象吧【笑】

哦，对了，既然题目叫『如何用R模拟婚姻市场的匹配问题』，那就不能忘了放上R代码是吧。为了行文流畅，我把代码放到了文后，请感兴趣的读者自行参考。

结果

终于到了大家期待的牵手结果阶段！让我们看看谁和谁在一起了！【八卦脸】

还是横行代表男生编号，纵列代表女生编号，『1』表示牵手成功。

整理结果如下：

每列分别代表：男生编号，女生编号，女生在男生心中的排名，男生在女生心中的排名。

我们观察到一些结果：

感想

做完这个练习，我也多少产生了一些感触：

是一个很成熟的研究领域，感兴趣的读者可以继续阅读参考文献中的论文。

我刚才发现，已经有人写出专门应用这个算法的R 了：

R :

看来网上果然是人才济济。我不是计算机专业出身，只是为了个人爱好才写这篇文章。欢迎懂行的各位与我交流！

最后。

你或许会觉得，你的另一半不是你最心仪的那个人。

但是在他/她眼中，你的爱可能胜过一切。

珍惜眼前人。

参考文献

Gale, D.; , L. S. 1962. and the of . 69: 9–14.

D. G. and L. B. . 1971. The .. ACM14, 7 (July 1971), 486-490.

Roth, Alvin E.. 1982. “The of : and ”. of (4). : 617–28.

, L. E., and D. A. . 1981. “ and the Gale- ”.The (7). of : 485–94.

, Gary. "A of ." (1974).

--

附录

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)