Skip to content

@floswald /dda2.r

Embed URL


Subversion checkout URL

You can clone with
Download ZIP
DDA code
# deferred acceptance algorithm after Gale and Shapley
# Deferred Acceptance Algorithm with male offer
# accepts your preferences or chooses randomly
daa <- function(nMen,nWomen,m.prefs=NULL,w.prefs=NULL){
require(animation) # load animation package
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)))
m.hist <- rep(0,length=nMen) # number of proposals made
w.hist <- rep(0,length=nWomen) # current mate <- 1:nMen <- 1:nWomen
m.mat <- matrix(data=1:nMen,nrow=nMen,ncol=nWomen,byrow=F)
saveGIF({ # this line and next are for recording the movie
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.hist[[i]] <- m.hist[[i]]+1 # make next proposal according to single i's count
offers[i] <- m.prefs[m.hist[[i]],[i]] # offer if single i is the index of the woman corresponding to current round
approached <- unique(offers) # index of women who received offers <- <- NULL # reset singles
for (j in approached){
proposers <-[offers==j]
stay.single <-[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])){ <- c(,w.hist[j]) # if proposer better, fire current guy
w.hist[j] <- proposers[k] # and take proposer on
} else { <- c(,proposers[k]) # otherwise k stays single
} <- sort(c(,stay.single))
if (length({ # if no singles left: stop
current.match <- (matrix(rep(w.hist,each=nMen),nrow=nMen,ncol=nWomen)==m.mat) <- matrix(m.mat %in%,nrow=nMen)*2
sub=paste("Iterations to go: ",nWomen-iter,". currently ",length(," males single", sep=""))
title("Current matches (black) and male singles (red)",line=3)
title(paste(nMen," men and ",nWomen," women",sep=""),line=2)
},"dda_plot.gif") # end movie recorder
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.