[R] Top Trading Cycles (TTC) Algorithm in R

[VictorDelgado]

Hello R users I'm posting here my recent implementation of Top Trading Cycles
Algorithm in R. For more details, look for Shapley and Scarf "On Cores and
Indivisibility" Journal of Mathematical Economics, 1, 23-37.

ttc.many <- function(m, n, preference.row, preference.col,expand)
{

# m = row number 
# n = col number 
# Remember, rows propose first in this code 
# expand = counter of seats per 'school' or column classes 
# Note that m > n is needed to algorithm to run 
# Comments in Portuguese 

##############################################################

students <- 1:m

# Condição dos alunos:
# Há alunos na lista?

loop <- 1
result <- matrix(0,nrow=m, ncol=2) # E gerar um resultado

repeat{
ciclo <- NULL
pos <- NULL
s.point <- students[1]

# E vamos armazenar o ciclo em um objeto:

ciclo <- c(ciclo, s.point)

while(all(duplicated(ciclo)==FALSE)){
i.point <- which.min(preference.row[s.point,]) # Para onde o primeiro aluno
da lista aponta:
s.point <- which.min(preference.col[,i.point]) # Para quem essa escola
aponta?
ciclo <- c(ciclo, s.point) # Para quem essa escola aponta formando o ciclo.
					} # FIM DO PEQUENO WHILE!

# Quem é o duplicado?

dup <- ciclo[which(duplicated(ciclo)==TRUE)]
start <- min(which(ciclo==dup))

# Ciclo apenas com os participantes e sem o repetido ao final:

ciclo <- ciclo[start:(length(ciclo)-1)]

for(i in ciclo){
escola <- which.min(preference.row[i,])
result[i,] <- c(i,escola)
preference.col[i,1:n] <- 2*m

if(expand[escola]>1){
expand[escola] <- expand[escola] - 1}else{
expand[escola] <- expand[escola] - 1
preference.row[,escola] <- 2*m}}

for(k in 1:length(ciclo)){
pos[k] <- which(students==ciclo[k])}
students <- students[-pos]

cat("interações =",loop,'\n')
flush.console()
loop <- loop+1
if(length(students) == 0){
break
}
} # FIM DO REPEAT!

result.matrix <- matrix(0, nrow=m, ncol=n)
for(j in result[,1]){
result.matrix[j,result[j,2]] <- 1}
result.matrix

} # FIM DA FUNÇÃO! END OF FUNCTION!

#####################################################

Simple test:

m1 <- c(2,1,3,4)
m2 <- c(1,2,3,4)
m3 <- c(3,2,1,4)
m4 <- c(3,4,1,2)
m5 <- c(1,4,2,3)
m6 <- c(2,3,4,1)
m7 <- c(1,2,3,4)
m8 <- c(1,2,4,3)

n1 <- c(1,2,3,4,5,6,7,8)
n2 <- c(7,6,1,3,2,8,5,4)
n3 <- c(3,5,2,8,1,7,4,6) 
n4 <- c(8,5,6,4,7,1,3,2)

preference.row <- matrix(c(m1,m2,m3,m4,m5,m6,m7,m8), nrow=8, byrow=TRUE)
preference.col <- matrix(c(n1, n2, n3, n4), ncol=4)
exp <- c(2,2,3,3) # Vector of Seats

gsa.many(m=8, n=4, preference.row=preference.row,
preference.col=preference.col, expand=exp))

####### SOME REFERENCES:

A. Abdulkadiroglu, T. Sonmez School Choice: A Mechanism Design Approach.
American Economic Review, 93(3):729–743, 2003.

L. S. Shapley, H. Scarf "On Cores and Indivisibility" Journal of
Mathematical Economics, 1, 23-37.

Klein, T. (2015). matchingMarkets: Structural Estimator and Algorithms for
the Analysis of Stable
Matchings. R package version 0.1-5.

https://cran.r-project.org/web/packages/matchingMarkets/index.html





-----
Victor Delgado
Professor in department of Economics,
UFOP - Univ. Federal de Ouro Preto, Brazil
--
View this message in context: http://r.789695.n4.nabble.com/Top-Trading-Cycles-TTC-Algorithm-in-R-tp4712649.html
Sent from the R help mailing list archive at Nabble.com.