R Notebook

rm(list=ls(all=TRUE))
setwd("~/Desktop/R/ad4")
library(dplyr)
library(matchingMarkets)
library(ggplot2)
library(reshape2)
library(scales)

Setup

1. 500students

2. 50schools

3. list:10

4. Waiting list:15

finaldf <- list()

for(times in 1:100){
  if(times>1){
    rm(list=ls()[c(-6,-33)])
    if(times%%10==0){
      print(times)
    }
  }
  examscore <- c(rep(0,500))
  for(i in 1:500){
    score <- 0
    for(j in 1:5){
      k <- sample(1:15,1)
      score=k+score
    }
    examscore[i]=score
  }
  examscore <- sort(examscore,decreasing = TRUE)
  examscore.df <- data.frame(score=examscore)
  examscore.df$rank <- c(1:500)
  
  for (i in 1:499){
    if(examscore.df$score[i]==examscore.df$score[i+1]){
      if(examscore.df$rank[i] < examscore.df$rank[i+1]){
        examscore.df$rank[i+1] <- examscore.df$rank[i]
      }
    }
  }
  
  #School Preference
  ranking <- c(1:500)
  school <- matrix(rep(ranking,50),nrow = 500)
  
  #Student Preference
  
  examscore.df$pred <- (examscore.df$rank%/%10)+1
  examscore.df$pred[examscore.df$pred>50] <- 50
  
  student <- matrix(rep(0,2500),nrow = 5)
  
  for( i in 1:500){
    if(examscore.df$pred[i]<3){
      student[,i] <- c(1:5)
    }else if(examscore.df$pred[i]>48){
      student[,i] <- c(46:50)
    }else{
      k <- examscore.df$pred[i]-2
      student[,i] <- c(k:(k+4))
    }
  }
  
  student_full <- matrix(rep(c(1:50),500),nrow=50)
  
  #match matrix
  match <- matrix(rep(0,25000),nrow = 500)
  for(i in 1:500){
    for(j in 1:5){
      k <- student[j,i]
      match[i,k] <- 1
    }
  }
  for(i in 1:50){
    n=0
    for(j in 1:500){
      if(match[j,i]==1){
        n=n+1
      }
      if(n>25){
        if(examscore.df$score[j-1]>examscore.df$score[j]){
          for(k in j:500){
            match[k,i] <- 0
          }
        }
      }
    }
  }
  #update
  
  student2 <- student
  school2 <- school
  
  for(i in 1:500){
    for(j in 1:5){
      k <- student[j,i]
      if(match[i,k]==0){
        student2[j,i] <- 9999
      }
    }
  }
  
  for(i in 1:50){
    for(j in 1:500){
      k <- school[j,i]
      if(match[k,i]==0){
        school2[j,i] <- 9999
      }
    }
  }
  
  student2[student2==9999] <- 0
  school2[school2==9999] <- 0
  
  #DA
  res <- hri(s.prefs = student2,c.prefs = school2,nSlots = rep(10,50))
  res.df <- res$matchings
  res.df <- as.data.frame(filter(res.df,sOptimal==1,matching==1))
  
  #analyze result
  student_res <- student
  for(j in 1:nrow(res.df)){
    st <- res.df$student[j]
    sc <- res.df$college[j]
    sl <- student_res[,st]
    for(i in 1:5){
      if(sl[i]!=sc){
        sl[i] <- 0
      }
    }
    student_res[,st] <- sl
  }
  
  for(i in 1:ncol(student_res)){
    if(sum(student_res[,i] != 0)!=1){
      student_res[,i] <- rep(0,5)
    }
  }
  
  wel1 <- c(rep(0,500))
  for(i in 1:ncol(student_res)){
    for(j in 1:nrow(student_res)){
      if(student_res[j,i]!=0){
        wel1[i] <- j
      }
    }
  }
  #DA
  res2 <- hri(s.prefs = student,c.prefs = school,nSlots = rep(10,50))
  res2.df <- res2$matchings
  res2.df <- as.data.frame(filter(res2.df,sOptimal==1,matching==1))
  
  #analyze result
  student_res2 <- student
  for(j in 1:nrow(res2.df)){
    st <- res2.df$student[j]
    sc <- res2.df$college[j]
    sl <- student_res2[,st]
    for(i in 1:5){
      if(sl[i]!=sc){
        sl[i] <- 0
      }
    }
    student_res2[,st] <- sl
  }
  
  for(i in 1:ncol(student_res2)){
    if(sum(student_res2[,i] != 0)!=1){
      student_res2[,i] <- rep(0,5)
    }
  }
  
  wel2 <- c(rep(0,500))
  for(i in 1:ncol(student_res2)){
    for(j in 1:nrow(student_res2)){
      if(student_res2[j,i]!=0){
        wel2[i] <- j
      }
    }
  }
  #DA
  resf <- hri(s.prefs = student_full,c.prefs = school,nSlots = rep(10,50))
  resf.df <- resf$matchings
  resf.df <- as.data.frame(filter(resf.df,sOptimal==1,matching==1))
  
  #analyze result
  student_resf <- student_full
  for(j in 1:nrow(resf.df)){
    st <- resf.df$student[j]
    sc <- resf.df$college[j]
    sl <- student_resf[,st]
    for(i in 1:nrow(student_resf)){
      if(sl[i]!=sc){
        sl[i] <- 0
      }
    }
    student_resf[,st] <- sl
  }
  
  for(i in 1:ncol(student_resf)){
    if(sum(student_resf[,i] != 0)!=1){
      student_resf[,i] <- rep(0,5)
    }
  }
  comp <- data.frame(res=c(rep(0,500)),
                     res2=c(rep(0,500)),
                     resf=c(rep(0,500)))
  for(i in 1:ncol(student_resf)){
    for(j in 1:nrow(student_res)){
      if(student_res[j,i]!=0){
        comp$res[i] <- student_res[j,i]
      }
    }
    for(m in 1:nrow(student_res2)){
      if(student_res2[m,i]!=0){
        comp$res2[i] <- student_res2[m,i]
      }
    }
    for(n in 1:nrow(student_resf)){
      if(student_resf[n,i]!=0){
        comp$resf[i] <- student_resf[n,i]
      }
    }
  }
  comp$dires <- 0
  comp$dires2 <- 0
  for(i in 1:ncol(student_resf)){
    if(comp$res[i]!=0){
      comp$dires[i] <- comp$resf[i]-comp$res[i]
    }else{
      comp$dires[i] <- NA
    }
    if(comp$res2[i]!=0){
      comp$dires2[i] <- comp$resf[i]-comp$res2[i]
    }else{
      comp$dires2[i] <- NA
    }
  }
  compdires.df <- as.data.frame(count(comp,dires))
  colnames(compdires.df) <- c("type","count")
  compdires2.df <- as.data.frame(count(comp,dires2))
  colnames(compdires2.df) <- c("type","count")
  finalres <- merge(compdires.df,compdires2.df,by="type",all = TRUE)
  finaldf <- append(finaldf,list(finalres))
  if(times%%10==0){
    print(times)
  }
}

Result

finaldfres <- finaldf[[1]][-3]
for(i in 1:99){
  finaldfres <- merge(finaldfres,finaldf[[i+1]][-3],by="type",all = TRUE)
}
finaldfres1 <- as.data.frame(finaldfres)
finaldfres <- finaldf[[1]][-2]
for(i in 1:99){
  finaldfres <- merge(finaldfres,finaldf[[i+1]][-2],by="type",all = TRUE)
}
finaldfres2 <- as.data.frame(finaldfres)
rownames(finaldfres1) <- as.character(c(finaldfres1[1:6,1],"NA"))
rownames(finaldfres2) <- as.character(c(finaldfres2[1:6,1],"NA"))
finaldfres1 <- finaldfres1[,2:101]
finaldfres2 <- finaldfres2[,2:101]
finaldfres1[is.na(finaldfres1)] <- 0
finaldfres2[is.na(finaldfres2)] <- 0
finaldfres1$sum <- rowSums(finaldfres1)
finaldfres2$sum <- rowSums(finaldfres2)
finaldfresmean <- data.frame(type=c(rownames(finaldfres1)),
                             with_step=finaldfres1$sum/50000,
                             with_out_step=finaldfres2$sum/50000)
level_order <- as.character(finaldfresmean$type)
brk <- c(0,0.25,0.50,0.75,1)
forgr <- melt(finaldfresmean)
resgr <- ggplot(forgr, aes(x = factor(type,level=level_order),y = value)) +
  facet_wrap(~variable, nrow=2, ncol=1) +
  scale_x_discrete()+
  scale_y_continuous(breaks=brk,labels = percent(brk))+
  geom_bar(stat = "identity",fill="lightseagreen")+
  geom_text(aes(y = value + .05, label = percent(value)),colour = "gray28")+
  geom_text(aes(y = value + .15,label=(value)*500),colour = "gray50")+
  xlab("Comparing to full DA")+
  ylab("percentage")+
  theme_gray()
resgr

---