[R] Fixing Gale-Shapley Algorithm for R

[VictorDelgado]

VictorDelgado wrote
> 
> gsa <- function(m, n, preference.row, preference.col, first)
> {
> # m: number of rows (men)
> # n: number of columns (women)
> # first 1 for row (men); and 2 for column (women)
> #
> # Two Auxiliary functions:
> # 1:
> min.n <- function(x,n,value=TRUE){
> s <- sort(x, index.return=TRUE)
> if(value==TRUE){s$x[n]} else{s$ix[n]}}
> 
> # 2:
> 
> max.n <- function(x,n,value=TRUE){
> s <- sort(x, decreasing=TRUE, index.return=TRUE)
> if(value==TRUE){s$x[n]} else{s$ix[n]}}
> #############################################################
> 
> s <- NULL
> test_s <-NULL
> loop <- 2 # O loop é necessário a partir do 2.
> step.1 <- matrix(0,ncol=n, nrow=m)
> step.2 <- matrix(0,ncol=n, nrow=m)
> store <- NULL
> r <- NULL
> 
> # Men proposing first:
> 
> if (first==1)
>         {
> step.1 <- matrix(0,ncol=n, nrow=m)
> for (i in 1:n)
>                 {
> step.1[i,][preference.row[i,]==min.n(preference.row[i,],n=1)] <- 1
>                 }
> for (i in 1:n){s[i] <- sum(step.1[,i])}
> test_s <- s>1
> while (any(test_s==TRUE)==TRUE)
>                         {
> if (any(test_s==TRUE)==TRUE) {
> position1 <- which(s>1)
> position2 <- vector('list')
> position3 <- vector('list')
> position4 <- NULL
> position5 <- 1:m
> for (k in 1:length(position1)){position2[[k]] <-
> which(step.1[,position1[k]]==1)
> position3[[k]] <-
> which(preference.col[,position1[k]]>min(preference.col[position2[[k]],position1[k]]))
> x <- which(position3[[k]]%in%position2[[k]])
> position3[[k]] <- position3[[k]][x]
> step.1[position3[[k]],position1[k]] <- 0}
> for (t in 1:n){position4[t] <-
> if(sum(step.1[,t])==0){0}else{which(step.1[,t]==1)}}
> position4 <- position4[position4 >0]
> position5 <- position5[-position4]
> store <- append(position5, store)
> r <- rle(sort(store))
> for (j in
> position5){step.1[j,][preference.row[j,]==r$lengths[r$values==j]+1] <- 1}
> for (i in 1:n){s[i] <- sum(step.1[,i])}
> test_s <- s>1
>                                         }else{
> step.1 <- matrix(0,ncol=m, nrow=n)
> for (i in 1:m){step.1[i,][preference.row[i,]==min(preference.row[i,])] <-
> 1}
> return(step.1)}
> loop <- loop + 1
>                         } #end of while
>         }
> 
> # Women proposing first:
> 
> if (first==2)
>         {
> step.2 <- matrix(0,ncol=n, nrow=m)
> for (i in 1:n)
>                 {
> step.2[,i][preference.col[,i]==min.n(preference.col[,i],n=1)] <- 1
>                 }
> for (i in 1:n){s[i] <- sum(step.2[i,])}
> test_s <- s>1
> while (any(test_s==TRUE)==TRUE)
>                         {
> if (any(test_s==TRUE)==TRUE) {
> position1 <- which(s>1)
> position2 <- vector('list')
> position3 <- vector('list')
> position4 <- NULL
> position5 <- 1:m
> for (k in 1:length(position1)){position2[[k]] <-
> which(step.2[position1[k],]==1)
> position3[[k]] <-
> which(preference.row[position1[k],]>min(preference.row[position1[k],position2[[k]]]))
> x <- which(position3[[k]]%in%position2[[k]])
> position3[[k]] <- position3[[k]][x]
> step.2[position1[k],position3[[k]]] <- 0}
> for (t in 1:n){position4[t] <-
> if(sum(step.2[t,])==0){0}else{which(step.2[t,]==1)}}
> position4 <- position4[position4 >0]
> position5 <- position5[-position4]
> store <- append(position5, store)
> r <- rle(store)
> for (j in
> position5){step.2[,j][preference.col[,j]==r$lengths[r$values==j]+1] <- 1}
> for (i in 1:n){s[i] <- sum(step.2[i,])}
> test_s <- s>1
>                                         }else{
> step.2 <- matrix(0,ncol=m, nrow=n)
> for (i in 1:m){step.2[i,][preference.col[,i]==min(preference.col[,i])] <-
> 1}
> step.2}
> loop <- loop + 1
>                         } # End of 2nd while
>         }
> if (first==1) {print(step.1)}
> if (first==2) {print(step.2)}
> }
> 

I Just have fixed some problems with the first function. Now it's running
with 100x100 (random preferences) matrices. The function still needing some
simplification.

gsa <- function(m, n, preference.row, preference.col, first)
{
#
########### TWO VERY USEFUL AUXILIARITY FUNCTIONS:
#
# Returns the n-esim minimun
# If value=TRUE it gives you the value, otherwise it returns the position.

min.n <- function(x,n,value=TRUE){
s <- sort(x, index.return=TRUE)
if(value==TRUE){s$x[n]} else{s$ix[n]}}

# Same Function for max:

max.n <- function(x,n,value=TRUE){
s <- sort(x, decreasing=TRUE, index.return=TRUE)
if(value==TRUE){s$x[n]} else{s$ix[n]}}
#############################################################

# 1 for men proposing; 2 for women.
s <- NULL
test_s <-NULL
loop <- 1 # Contagem das iterações.
step.1 <- matrix(0,ncol=n, nrow=m)
step.2 <- matrix(0,ncol=n, nrow=m)
store <- NULL
r <- NULL 

# Men proposing:

if (first==1)
	{
step.1 <- matrix(0,ncol=n, nrow=m)
for (i in 1:m)
		{
step.1[i,][preference.row[i,]==min.n(preference.row[i,],n=1)] <- 1
		}
for (i in 1:m){s[i] <- sum(step.1[,i])}
test_s <- s>1 
while (any(test_s==TRUE)==TRUE)
			{
if (any(test_s==TRUE)==TRUE)	{
position1 <- which(s>1)
position2 <- vector('list')
position3 <- vector('list')
position4 <- NULL
position5 <- 1:n
for (k in 1:length(position1)){position2[[k]] <-
which(step.1[,position1[k]]==1)			
position3[[k]] <-
which(preference.col[,position1[k]]>min(preference.col[position2[[k]],position1[k]]))
x <- which(position3[[k]]%in%position2[[k]])
position3[[k]] <- position3[[k]][x]
step.1[position3[[k]],position1[k]] <- 0}
for (t in 1:n){position4[t] <-
if(sum(step.1[,t])==0){0}else{which(step.1[,t]==1)}}
position4 <- position4[position4 >0]
position5 <- position5[-position4]
store <- append(position5, store)
r <- rle(sort(store))
for (j in
position5){step.1[j,][preference.row[j,]==r$lengths[r$values==j]+1] <- 1}
for (i in 1:n){s[i] <- sum(step.1[,i])}
test_s <- s>1	
					}else{
step.1 <- matrix(0,ncol=m, nrow=n)
for (i in 1:n){step.1[i,][preference.row[i,]==min(preference.row[i,])] <- 1}
return(step.1)}
loop <- loop + 1
			} #end of while
	}

# Women proposing:

if (first==2)
	{
step.2 <- matrix(0,ncol=n, nrow=m)
for (i in 1:n)
		{
step.2[,i][preference.col[,i]==min.n(preference.col[,i],n=1)] <- 1
		}
for (i in 1:n){s[i] <- sum(step.2[i,])}
test_s <- s>1 
while (any(test_s==TRUE)==TRUE)
			{
if (any(test_s==TRUE)==TRUE)	{
position1 <- which(s>1)
position2 <- vector('list')
position3 <- vector('list')
position4 <- NULL
position5 <- 1:m
for (k in 1:length(position1)){position2[[k]] <-
which(step.2[position1[k],]==1)
position3[[k]] <-
which(preference.row[position1[k],]>min(preference.row[position1[k],position2[[k]]]))
x <- which(position3[[k]]%in%position2[[k]])
position3[[k]] <- position3[[k]][x]
step.2[position1[k],position3[[k]]] <- 0}
for (t in 1:m){position4[t] <-
if(sum(step.2[t,])==0){0}else{which(step.2[t,]==1)}}
position4 <- position4[position4 >0]
position5 <- position5[-position4]
store <- append(position5, store)
r <- rle(sort(store))
for (j in
position5){step.2[,j][preference.col[,j]==r$lengths[r$values==j]+1] <- 1}
for (i in 1:n){s[i] <- sum(step.2[i,])}
test_s <- s>1	
					}else{
step.2 <- matrix(0,ncol=m, nrow=n)
for (i in 1:m){step.2[i,][preference.col[,i]==min(preference.col[,i])] <- 1}
return(step.2)}
loop <- loop + 1
			} # End of 2nd while
	}
if (first==1) {print(step.1)}
if (first==2) {print(step.2)}
print(loop)
}

-----
Victor Delgado
cedeplar.ufmg.br P.H.D. student
www.fjp.mg.gov.br reseacher
--
View this message in context: http://r.789695.n4.nabble.com/Gale-Shapley-Algorithm-for-R-tp4240809p4395067.html
Sent from the R help mailing list archive at Nabble.com.