Skip to content

Instantly share code, notes, and snippets.

@arademaker
Last active August 29, 2015 14:03
Show Gist options
  • Save arademaker/b675a20c6cbb3316f450 to your computer and use it in GitHub Desktop.
Save arademaker/b675a20c6cbb3316f450 to your computer and use it in GitHub Desktop.
code of stable matching problem in R
# Solucao baseada no pseudo-codigo apresentado em:
# http://en.wikipedia.org/wiki/Stable_marriage_problem
stable.match <- function(hprefs, mprefs, debug=FALSE){
proposed <- matrix(rep(FALSE,25), ncol = 5, dimnames = list(Homens = 1:5, Mulheres = 1:5))
alloc <- matrix(rep(FALSE,25), ncol = 5, dimnames = list(Homens = 1:5, Mulheres = 1:5))
# os nomes das linhas e colunas irao ser usados para indicar os
# indices para selecao de elementos das matrizes proposed e alloc,
# por isso precisam ser renomeados.
dimnames(hprefs) <- lapply(dimnames(hprefs), function(x) substr(x,2,2))
dimnames(mprefs) <- lapply(dimnames(mprefs), function(x) substr(x,2,2))
# Explicacao sobre o argumento "..." na pagina 55 do livro
# "Introducao a programacao em R"
mycat <- function(...) {
if(debug)
cat(...)
}
husband <- function(woman){
x <- names(which(alloc[,woman]))
if(length(x) == 0)
return(0)
else
return(x)
}
# O interessante aqui é o uso do rbind para criarmos uma matriz com
# as preferencias e propostas feitas por um dado homen.
has.options <- function(man){
options <- rbind(hprefs[man,], proposed[man,])
options[1,options[2,] == 0]
}
free.men <- function(){
names(which(!apply(alloc,1, any)))
}
while( length(free.men()) > 0 && length(has.options(free.men()[1])) > 0 ){
man <- free.men()[1]
woman <- names(which.max(has.options(man)))
mycat(" try: ", c(man, woman), "\n")
if ( husband(woman) == 0 ) {
alloc[man, woman] <- TRUE
mycat(" maried: ", c(man,woman), "\n")
} else {
if( mprefs[woman,man] > mprefs[woman,husband(woman)] ) {
mycat("Divorced: ", c(husband(woman),woman), "\n")
mycat(" Maried: ", c(man,woman), "\n")
alloc[husband(woman), woman] <- FALSE
alloc[man, woman] <- TRUE
}
}
proposed[man, woman] <- TRUE
mycat("proposed: ", c(man, woman), "\n")
}
# Em rodadas armazenamos o número de elementos na matriz proposed
# com TRUE, indicando a quantidade de vezes que o corpo do while foi
# executado.
retorno <- list(casamentos = alloc, propostas = proposed, rodadas = length(which(proposed)))
mycat("--> rodadas: ", retorno$rodadas, "\n")
return(retorno)
}
# Testando a funcao
for(z in 1:15){
a <- matrix(sample(1:100,25, replace=FALSE), ncol = 5,
dimnames = list(Homens = paste("H",1:5, sep=""), Mulheres = paste("M",1:5, sep="")))
b <- matrix(sample(1:100,25, replace=FALSE), ncol = 5,
dimnames = list(Mulheres = paste("M",1:5, sep=""), Homens = paste("H",1:5, sep="")))
# debug=TRUE imprimi as mudancas de valores
x <- stable.match(a,b, debug=FALSE)
# verificando se nao existe homem solteiro ou poligamia
print( all(dim(which(x$casamentos, arr.ind=TRUE)) == c(5,2)) )
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment