:~/Matching Soulmates (JPET)

Citation

Paper

Matching Soulmates in R

#Operator "m %r% f" applies function "f" to matrix "m" by rows. 
%r% <- function(m,f){t(apply(m,1,match.fun(f)))}

#Operator "m %rm% i" removes rows and column indicies "i" from matrix "m". 
%rm% <- function(m,i){if(length(i)>0){m[-i,-i]}else{m}}



#Operator applies function "f" across list "l" with sapply.
%s% <- function(l,f){sapply(l,match.fun(f))}

#Returns Hadamard product of matrix m with its transpose.
hadamard <- function(m){m * t(m)}

#Given preference matrix, returns vector of player indicies who are first-order soulmates.
whos_a_soulmate <- function(p){which((p%r%rank%>%hadamard%r%min)==1)}

#Removes first order soulmates from preference matrix p.
remove_soulmates <- function(p){p %rm% whos_a_soulmate(p) %>% as.matrix}

#Recursively applies remove_soulmates until there's none left to remove.
ims <- function(p){if(dim(p)[1]==0 || identical(remove_soulmates(p),p)){p}else{ims(remove_soulmates(p))}}

#Create a random roommates preference matrix with "dim" players.
create_preference <- function(dim){
p <- matrix(runif(dim*dim),dim,dim,byrow=TRUE)
diag(p)<- 1
p %r% rank
}

#Set up parameters. "dim" is the number of players. "n" is the number of random trials. 
dim <- 10
n <- 100

#Create List of "n" Preference Matricies with "dim" players.
preference_list <- lapply(1:n,function(x){create_preference(dim)})

#Apply IMS to the list of preferences then count the number of players remaining.
remaining <- preference_list %s% ims %s% dim 

#Get the number of players removed by IMS.
removed <- dim - remaining[1,]

#Make a table of frequencies of the number of removed players.
removed %>% table/n