マッチングという制度がある。いくつかの候補となるところを試験や面接を受けて採用候補者としてもらい(でも試験受けたけど候補リストに挙がらないとかあるの?)、こちらも採用してほしいところを順番に入力したら、あとはコンピューターが勝手に計算してくれると。
元は安定結婚問題として、2012年にノーベル経済学賞を受賞したShapley先生が提唱した問題に帰着するらしい。雰囲気的には最適割付問題(シンプレックス法)に似ているが、得点行列を自分も相手も持つのでそこらへんが違うのだろう。
人を
つの候補に一斉に当てはめるアルゴリズムなので、例えば、日本の就活のような「内定○つの企業からもらった!!どこにしよう(ｸﾞﾍﾍ」や、「無い内定…欝だﾀﾋろう三┏( ^o^)┛|樹海→」という事態によって、欠員や過剰供給を避けたい分野で行われるらしい。計算時間としては
のオーダーで増える。だからといって2週間も計算に時間はかからないと思うが…
RではSyNetパッケージのなかに、
stableocuple
というそれらしい関数があったのだが、よくわからないのでここからパクった。
問題としては、候補者同士すべてに順位を付けなければならないということで、お互い候補にし合わないとマッチングしない仕様に実装できなかった。時間があればや…たぶんやらないなあ…
この問題の解説例題って、「男が女に求婚する」状況が多いような気がするのだが…
daa <- function(nMen, nWomen, m.prefs=NULL, w.prefs=NULL){ if (is.null(m.prefs)){ # if no prefs given, make them randomly m.prefs <- replicate(n=nMen,sample(seq(from=1,to=nWomen,by=1))) w.prefs <- replicate(n=nWomen,sample(seq(from=1,to=nMen,by=1))) } mw <- ifelse(nMen >= nWomen, 1, 2) m.hist <- rep(0, length=nMen) # number of proposals made w.hist <- rep(0, length=nWomen) # current mate m.singles <- 1:nMen w.singles <- 1:nWomen m.mat <- matrix(data=1:nMen, nrow=nMen, ncol=nWomen, byrow=FALSE) for (iter in 1:nWomen){ # there are as many rounds as maximal preference orders # look at market: all single men # if history not full (been rejected by all women in his prefs) # look at single male's history # propose to next woman on list offers <- NULL for (i in 1:length(m.singles)){ m.hist[m.singles[i]] <- m.hist[m.singles[i]]+1 # make next proposal according to single i's count offers[i] <- m.prefs[m.hist[m.singles[i]], m.singles[i]] # offer if single i is the index of the woman corresponding to current round } approached <- unique(offers) # index of women who received offers temp.singles <- m.singles m.singles <- NULL # reset singles for (j in approached){ proposers <- temp.singles[offers==j] stay.single <- temp.singles[offers==0] # guys who prefer staying single at current history for (k in 1:length(proposers)){ if (w.hist[j]==0 & any(w.prefs[, j]==proposers[k])){ # if no history and proposer w.hist[j] <- proposers[k] # is somewhere on preference list, accept } else if (match(w.prefs[w.prefs[, j]==proposers[k], j],w.prefs[, j])<match(w.prefs[w.prefs[, j]==w.hist[j], j],w.prefs[, j])){ m.singles <- c(m.singles,w.hist[j]) # if proposer better, fire current guy w.hist[j] <- proposers[k] # and take proposer on } else { m.singles <- c(m.singles, proposers[k]) # otherwise k stays single } } } m.singles <- sort(c(m.singles,stay.single)) current.match <- (matrix(rep(w.hist,each=nMen), nrow=nMen, ncol=nWomen)==m.mat) current.singles <- matrix(m.mat %in% m.singles, nrow=nMen)*2 current.singles[, which(colSums(current.match) == 0)] <- 2 No.singles <- c(sum(rowSums(current.match) == 0), sum(colSums(current.match) == 0))[mw] label0 <- paste("Iterations to go: ",nWomen-iter,". currently ", No.singles, " left to be single", sep="") image(y=1:nWomen, x=1:nMen, z=current.match+current.singles, ylab="", xlab=label0, col=c("white","black","red"[nMen!=nWomen])) title("Current matches (black) and male singles (red)", line=3) title(paste(nMen," rows and ",nWomen," cols",sep=""), line=2) grid(nx=nMen, ny=nWomen, col="black", lty=1) if (No.singles == abs(nMen - nWomen)) break } return(list(m.prefs=m.prefs, w.prefs=w.prefs, iterations=iter, matches=w.hist, match.mat=current.match, singles=m.singles)) } nMen <- 100 nWomen <- 80 m.prefs <- replicate(nMen, sample(seq(nWomen))) w.prefs <- replicate(nWomen, sample(seq(nMen))) daa0 <- daa(nMen, nWomen, m.prefs, w.prefs)
a <- matrix(c(1,3,1,3,2,2,2,1,3,1,4,4,4,4,3,2), 4, byrow=TRUE) b <- matrix(c(1,2,2,1,2,1,3,4,3,4,1,3,4,3,4,2), 4, byrow=TRUE) daa(4, 4, a, b)
