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

Tue Sep 22 22:40:17 CEST 2015

```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

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

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!

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

-----