[R] Fixing Gale-Shapley Algorithm for R

[VictorDelgado]

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.