Hello R Developers, I have made a new code for this algorithm in R. In the
end I present an very small example with system.time computing.
Gale-Shapley Many-to-One (Note that many are always in Rows):
#############################################
#############################################
gsa.many <- function(m, n, preference.row, preference.col, expand)
{
# m = row number
# n = col number
# Remember, rows propose first in this code
# expand = seats per 'school' or column classes
# Note that m > n is needed to algorithm to run
# Comments in Portuguese
loop <- 1 # marcação do primeiro loop
result <- matrix(0,nrow=m, ncol=n) # Matriz zerada
pos <- NULL # Para ver a posição do número mais escolhido
surplus <- 1 # Só para servir de condição inicial.
# Core of the Function:
while(any(surplus > 0)){ # Testa a consição se o número de alunos é maior
que o número de vagas
# Obtenção das propostas:
for(i in 1:m){
pos[i] <- which.min(preference.row[i,])
result[i,pos[i]] <- 1}
# Vamos obter quantos alunos requisitam as vagas:
demand <- apply(result, 2, sum)
surplus <- demand - expand # quantos alunos excedentes
# Qual(is) escola(s) terá(ão) de tirar alunos:
escolas <- which(surplus > 0)
rejected <- list(NULL) # Vai ser usado p/ descobrir os alunos que precisam
ser retirados:
surplus <- surplus[surplus > 0] # Quantos alunos estão sobrando
# Vamos criar uma lista auxiliar para o FOR abaixo:
if(length(surplus) > 0){
aux <- list(NULL)
for(i in 1:length(escolas)){
aux[[i]] <- escolas[i]} # ESSA LISTA Coloca a escolas na ordem
for(i in 1:length(escolas)){
proponents <- which(result[,aux[[i]]] == 1)
decreasing <- sort(preference.col[proponents,aux[[i]]], decreasing = TRUE)
rejected <- decreasing[1:surplus[i]]
retirar <- NULL
for(k in 1:length(rejected)){
retirar[k] <- which(preference.col[,aux[[i]]]==rejected[k])
retirar <- sort(retirar)}
preference.row[retirar,aux[[i]]] <- 2*m
result[retirar,aux[[i]]] <- 0} # FIM DOS DOIS FOR DA ESCOLA!!
} # FIM DO IF
cat("interações =",loop,'\n')
flush.console()
loop <- loop+1} # FIM DO WHILE!
# Cospe RESULT
result
} # FIM DA FUNÇÃO! END OF FUNCTION!
#####################################
Comparing Time of previous function with new one:
#####################################
# Setting the Example:
set.seed(51)
m <- 1
n <- 20
S <- NULL
while(m <= 100){
S <- append(S,sample(1:n,n))
m <- m + 1}
m <- m - 1
Pi <- matrix(S, nrow = m, byrow = TRUE)
R <- NULL
n <- 1
while(n <= 20){
R <- append(R,sample(1:m,m))
n <- n + 1}
n <- n - 1
Ps <- matrix(R, nrow=m)
vac <- c(rep(10,5),rep(5,5),rep(4,5),rep(1,5))
######################################
# PREVIOUS CODE
system.time(gsa.many2(m = m, n = n, preference.row = Pi, preference.col =
Ps, first = 1, expand = vac)) # In fact this functions have small changes to
apply a school Vector, please e-mail me for details.
user system elapsed
0.09 0.05 0.15
# NEW CODE
system.time(gsa.many(m = m, n = n, preference.row = Pi, preference.col = Ps,
expand = vac))
user system elapsed
0.03 0.02 0.04
R Version:
Rx64 3.0.1
My Machine:
i7 3770 CPU @ 3.40 GHz 16GB RAM
-----
Victor Delgado
cedeplar.ufmg.br P.H.D. student
UFOP assistant professor
--
View this message in context:
http://r.789695.n4.nabble.com/Gale-Shapley-Algorithm-for-R-tp4240809p4712636.html
Sent from the R help mailing list archive at Nabble.com.
______________________________________________
R-help@r-project.org mailing list -- To UNSUBSCRIBE and more, see
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
