■

• 輪読で勉強した Gale-Shapley アルゴリズムを R-code で組んでみました。
  • men と women の preference matrix を入れると complete stable matching を返します。

## Gale-Shapley algorithm
gs <- function(m_pref, w_pref){
  ## pref: n x n matrix. m_pref for men, w_pref for women. 
  ## (i,j)-elemnt of preference matrix denotes j-th favor of the i-th person
  ##
  ## Inputs
  ## m_pref: preference matrix of men
  ## w_pref: preference matrix of women
  ## Outputs
  ## list(S=S, m_pref=m_pref, w_pref=w_pref):
  ## S: complete stable matching
  ## m_pref, w_pref: preference matrices
  m_dim <- dim(m_pref); w_dim <- dim(w_pref)
  if (m_dim[1]!=m_dim[2] | any(m_dim != w_dim)) stop("m_pref shoud be square matrix")
  n <- m_dim[1]
  m_proposed <- array(1,n) ## index of highest-ranked woman to whom man has not yet proposed
  m_engage <- array(0,n)   
  idx <- which((m_engage==0) & (m_proposed<=n))
  while(length(idx)>0){
    m <- idx[1]
    w <- m_pref[m,m_proposed[m]]
    m_proposed[m] <- m_proposed[m]+1
    if (all(m_engage!=w)){
      m_engage[m] <- w
    }else{
      ms <- which(m_engage==w)
      if (which(w_pref[w,]==ms) > which(w_pref[w,]==m)){
        m_engage[m] <- w
        m_engage[ms] <- 0
      }
    }
    idx <- which((m_engage==0) & (m_proposed<=n))
  }
  S <- c()
  for (m in 1:n)
    S <- rbind(S,c(m,m_engage[m]))
  dimnames(S)[[2]] <- c("m","w")
  list(S=S, m_pref=m_pref, w_pref=w_pref)
}

• • 使いかた

n <- 3
m_pref <- c(); w_pref <- c()
for (i in 1:n){
  m_pref <- rbind(m_pref,sample(n,n))
  w_pref <- rbind(w_pref,sample(n,n))
}
gs(m_pref,w_pref)