Allocating subjects to students, whilst keeping subject and supervisor availability in account with linear programming

Question

I've turned to mixed-integer linear programming (MILP) to assign students to a subject and a supervisor for their projectwork, to maximize their preferences.

Supervisors each have a set of possible subjects that students can choose from. Students have to put 5 preferences up (from high to low preference) for a subject and we attempt to assign them the subject with their highest preference. Each student has to be assigned one subject.

The problem with the assignment is that supervisors only have a limited availability to supervise students (they put up more subjects than they can supervise to allow more choice) and each subject can only be picked once. Supervisors can also only supervise their own subjects.

I've started to solve this problem using the OMPR R package. Below you can find my code.

It keeps the availability of a subject in mind, but it doesn't take the availability of the supervisors into account. Thus the result is that supervisors are assigned too many subjects.

I realize that this is the culprit, as it will always return 1-0 and not the amount of assigned subjects to a supervisor.

#Constraint: the availability of the supervisor
add_constraint(sum_over(x[i, j], i = 1:n) <= get_cap(j), j = 1:m) 

get_cap can get the availability of the promotor using subject 'j', as each subject is assigned to a supervisor.

I think I'm looking for the sum of assigned subjects of students for a given supervisor, however I'm not sure how I should implement this constraint within the model.

Thank you!

library(tidyverse)
library(ompr)
library(ompr.roi)
library(ROI.plugin.glpk)

## Functions -----------
get_supervisor <- function(j){
  s <- subjects_df %>%
    filter(subject_id == j) %>%
    pull(supervisor_id)
  
  return(unique(s))
}

get_cap <- function(j){
  s <- subjects_df %>%
    filter(subject_id == j) %>%
    pull(supervisor_id)
  
  return(supervisor_cap[s])
}

## Data generation --------------
# amount of students
n <- 50

# amount of subjects
m <- 100

# amount of supervisors
o <- 10

subjects_df <- data.frame(
  subject_id = 1:m,
  supervisor_id = sample(1:o)
)

choices_df <- data.frame(
  student_id = 1:n,
  first = sample(1:m, n),
  second = sample(1:m, n),
  third = sample(1:m, n)
)

subjects_cap <- sample(1:2, m, replace = TRUE)
supervisor_cap <- sample(8:10, o, replace = TRUE)

weight_s <- function(student, subject){
  p <- choices_df %>%
    filter(student_id == student) %>%
    ungroup() %>%
    mutate(
      priority = case_when(
        first == subject ~ 3,
        second == subject ~ 2,
        third == subject ~ 1,
        TRUE ~ -10000
      )
    )
  
  return(as.numeric(p$priority))
}

# Model ---------------

model <- MIPModel() %>%
  # Decision variable: binary to show whether a student is assigned a subject
  add_variable(x[i, j], i = 1:n, j = 1:m, type = "binary") %>%
  
  #Goal: maximize the preferences of students
  set_objective(sum_over(weight_s(i, j) * x[i, j], i = 1:n, j = 1:m)) %>%
  
  #Constraint: the availability of the subject
  add_constraint(sum_over(x[i, j], i = 1:n) <= subjects_cap[j], j = 1:m) %>%
  
  #Constraint: the availability of the supervisor
  add_constraint(sum_over(x[i, j], i = 1:n) <= get_cap(j), j = 1:m) %>%
  
  #Constraint: each student requires exactly 1 subject
  add_constraint(sum_over(x[i, j], j = 1:m) == 1, i = 1:n)

result <- solve_model(model, with_ROI(solver = "glpk", verbose = TRUE))

matching <- result %>%
  get_solution(x[i, j]) %>%
  filter(value > .9) %>%
  select(i, j) %>%
  rename(s_number = i, subject_id = j) %>%
  rowwise() %>%
  mutate(weight = weight_s(s_number, subject_id)) %>%
  mutate(supervisor_id = get_supervisor(subject_id))

sum <- matching %>%
  group_by(supervisor_id) %>%
  summarize(n())