R 中的优化 - 给每个场合一个组长，每个人都应该至少被选择一次
Optimisation in R - giving each occasion a group leader, every person should be chosen at least once
我正在尝试为我的 class 创建一个时间表。
我有38个学生。我将在 11 (5+6) 次（BES 和 PBL）中与他们见面。
每次他们都被随机分为 8 组，结果是 6 组 5 人和 2 组 4 人。
对于每一个场合，我想选择一个学生来领导那个小组——一个领导者。我希望每个学生都当过一次小组组长。
我最多通过以下方式获得36个独特的领导者。
有没有办法 运行 在 R 中进行优化，以便我想要一个 objective 函数来最大化唯一领导者的数量？我的猜测是当前的限制是通过随机抽样分组的方式。
set.seed(13)
studentlist <- data.frame(Name=as.character(c(paste0("A",seq(1:38)))))
studentlist$PBL1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES6 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist <- as.data.frame(studentlist)
BES_leaders <- studentlist %>% select(Name, BES1:BES6) %>% pivot_longer(cols = "BES1":"BES6",names_to = "Occassion",values_to = "Group")
#initiate i to count set.seed
i <- 1
#initialise best solution
BES_leaders3 <- data.frame()
while(length(unique(BES_leaders2$Leader))<=36) {
set.seed(i)
return.i <- i
BES_leaders_2 <- BES_leaders %>% nest_by(Occassion,Group) %>% mutate(Leader= sample(c(data$Name),1,replace = FALSE)) %>% select(Occassion,Group,Leader)
BES_leaders2 <- as.data.frame(BES_leaders_2)
BES_leaders3 <- if(length(unique(BES_leaders2$Leader)) > length(unique(BES_leaders3$Leader))){BES_leaders2} else {BES_leaders3}
i <- i+1
print(length(unique(BES_leaders3$Leader)))
}
这是一个简化的问题，将 5 名领导者分配到 10 组，每组 5 人，（每个人两次成为领导者）
m1 <- replicate(10, sample(1:5, 5)) #randomize 10 groups of 5
leaders <- c(1:5, 1:5) # create the leader top row
m2 <- rbind(leaders, m1) # bind the leader row to the random groups
m3 <- apply(m2, 2, unique) # remove the redundant leaders from each group
你会做同样的事情，但要针对 76 个小组的 38 名学生。然后简单地随机化剩余的 12 个组，任意分配领导者并将它们绑定到 m3。
我们可以将其表述为优化问题：
引入符号：
i : set of occasions (11)
s : set of students (38)
g : set of groups (8)
计算
gsi[g,s,i] = 1 if student s is in group g at occasion i
0 otherwise
this is calculated from your studentlist
定义变量：
leader[i,s] = 1 if student s is leader at occasion i
0 otherwise
countTimes[s] : number of times student s is a leader
max : max(countTimes[s])
min : min(countTimes[s])
构建模型：
minimize max - min
subject to
sum(s, gsi[g,s,i]*leader[i,s]) = 1 for all i,g
countTimes[s] = sum(i,leader[i,s])
countTimes[s] <= max for all s
countTimes[s] >= min for all s
对我来说：
---- 95 PARAMETER lead
A1 A2 A3 A4 A5 A6 A7 A8 A9
PBL2.group4 1
PBL3.group6 1
PBL4.group2 1
PBL4.group4 1
PBL4.group7 1
PBL5.group6 1
PBL5.group7 1
BES1.group1 1
BES1.group4 1
BES1.group8 1
BES2.group3 1
BES2.group4 1
BES3.group4 1
BES3.group7 1
BES4.group5 1
BES4.group6 1
BES4.group8 1
BES5.group1 1
BES5.group2 1
BES5.group3 1
BES6.group1 1
BES6.group6 1
+ A10 A11 A12 A13 A14 A15 A16 A17 A18
PBL1.group1 1
PBL1.group2 1
PBL1.group4 1
PBL1.group8 1
PBL2.group1 1
PBL2.group7 1
PBL3.group4 1
PBL5.group2 1
PBL5.group4 1
PBL5.group5 1
BES1.group7 1
BES2.group1 1
BES2.group5 1
BES4.group1 1
BES4.group4 1
BES5.group5 1
BES5.group8 1
BES6.group7 1
BES6.group8 1
+ A19 A20 A21 A22 A23 A24 A25 A26 A27
PBL1.group3 1
PBL1.group5 1
PBL2.group2 1
PBL2.group3 1
PBL2.group8 1
PBL3.group2 1
PBL3.group7 1
PBL4.group1 1
PBL4.group3 1
PBL4.group6 1
PBL5.group1 1
PBL5.group3 1
BES3.group1 1
BES3.group2 1
BES4.group3 1
BES4.group7 1
BES5.group4 1
BES5.group6 1
BES6.group2 1
BES6.group4 1
BES6.group5 1
+ A28 A29 A30 A31 A32 A33 A34 A35 A36
PBL1.group7 1
PBL2.group5 1
PBL2.group6 1
PBL3.group1 1
PBL3.group3 1
PBL4.group5 1
PBL4.group8 1
PBL5.group8 1
BES1.group2 1
BES1.group3 1
BES1.group5 1
BES1.group6 1
BES2.group2 1
BES2.group6 1
BES2.group7 1
BES2.group8 1
BES3.group5 1
BES3.group6 1
BES3.group8 1
BES4.group2 1
BES5.group7 1
+ A37 A38
PBL1.group6 1
PBL3.group5 1
PBL3.group8 1
BES3.group3 1
BES6.group3 1
每个学生都是领导者的两倍或三倍。我没有使用 R，而是使用商业工具。我会看看我是否可以在 R 中做到这一点。
R 实现可能如下所示：
library(dplyr)
library(ROI)
library(ROI.plugin.glpk)
library(ompr)
library(ompr.roi)
numStudents <- 38
numGroups <- 8
numMeetings <- 11
# code from question
set.seed(13)
studentlist <- data.frame(Name=as.character(c(paste0("A",seq(1:38)))))
studentlist$PBL1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES6 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist <- as.data.frame(studentlist)
studentlist
# form 3d binary matrix
gsi <- array(0L,dim=c(numGroups,numStudents,numMeetings))
for (s in 1:numStudents)
for (i in 1:numMeetings) {
g <- studentlist[s,i+1]
gsi[g,s,i] = 1L
}
result <- MIPModel() %>%
add_variable(leader[i,s], i=1:numMeetings, s=1:numStudents, type = "binary") %>%
add_variable(count[s], s=1:numStudents) %>%
add_variable(max) %>%
add_variable(min) %>%
set_objective(max-min, "min") %>%
add_constraint(sum_expr(gsi[g,s,i]*leader[i,s], s=1:numStudents) == 1, i=1:numMeetings, g=1:numGroups) %>%
add_constraint(count[s] == sum_expr(leader[i,s], i=1:numMeetings), s=1:numStudents) %>%
add_constraint(count[s] <= max, s=1:numStudents) %>%
add_constraint(count[s] >= min, s=1:numStudents) %>%
add_constraint(min >= 1) %>%
# too slow to prove optimality. We stop after 200 seconds.
solve_model(with_ROI(solver="glpk", verbose=T, tm_limit=20000)) %>%
get_solution(leader[i,s]) %>%
filter(value > 0)
result2 <- matrix(0L,nrow=numStudents,ncol=numMeetings)
for (k in 1:nrow(result)) {
i <- result$i[k]
s <- result$s[k]
result2[s,i] <- 1
}
rownames(result2) <- studentlist$Name
colnames(result2) <- colnames(studentlist)[-1]
result2
求解器不够强大，无法证明最优性，但我们应该在（远）少于 200 秒的时间限制 (objective=1) 内找到最优解。 result2 输出如下所示：
> result2
PBL1 PBL2 PBL3 PBL4 PBL5 BES1 BES2 BES3 BES4 BES5 BES6
A1 0 1 0 1 0 0 1 0 0 0 0
A2 1 0 0 0 0 0 0 0 1 1 0
A3 0 0 1 0 0 0 0 1 0 1 0
A4 1 0 1 1 0 0 0 0 0 0 0
A5 1 0 0 0 1 0 0 1 0 0 0
A6 0 0 0 1 0 0 0 0 1 1 0
A7 0 0 0 0 0 0 1 1 1 0 0
A8 0 1 0 0 1 1 0 0 0 0 0
A9 1 0 0 0 1 0 0 0 0 0 0
A10 0 1 1 0 0 0 0 0 0 0 0
A11 0 0 1 0 0 0 0 1 0 0 0
A12 1 0 0 0 0 0 0 0 1 0 0
A13 0 0 0 1 0 1 0 0 0 0 0
A14 0 0 0 0 0 0 1 1 0 0 0
A15 0 0 0 0 0 0 0 0 1 0 1
A16 0 1 0 0 0 1 0 0 0 0 1
A17 0 1 0 0 1 0 0 0 0 0 0
A18 0 0 0 0 0 0 1 0 0 1 0
A19 0 0 0 0 1 0 0 0 0 1 0
A20 1 0 0 0 0 1 0 0 0 0 0
A21 0 0 0 0 0 0 1 0 0 0 1
A22 0 1 0 0 0 1 0 0 0 0 0
A23 0 0 0 0 0 0 0 0 0 1 1
A24 0 0 0 0 1 0 0 0 0 0 1
A25 0 0 0 0 0 1 0 0 0 0 1
A26 0 0 0 0 0 0 1 0 1 0 0
A27 0 0 1 0 0 0 0 1 0 0 0
A28 0 0 0 1 0 0 0 1 0 1 0
A29 1 0 0 0 0 0 0 0 0 0 1
A30 1 0 0 1 0 0 1 0 0 0 0
A31 0 0 0 0 0 1 0 1 0 0 0
A32 0 0 1 0 0 0 1 0 0 0 0
A33 0 0 1 0 0 0 0 0 1 0 0
A34 0 0 1 0 0 0 0 0 0 1 0
A35 0 1 0 0 1 0 0 0 1 0 0
A36 0 0 0 1 0 0 0 0 0 0 1
A37 0 1 0 0 0 1 0 0 0 0 0
A38 0 0 0 1 1 0 0 0 0 0 0
此解决方案遵循类似 SteveM 的方法，即按顺序将领导者分配给场合和小组。然而，它明确地处理了两个小组的规模，并在不同的小组和场合随机分配学生。它仅使用基础 R 和 tidyverse。所有学生都被指定为领导者两次或三次。
library(tidyverse)
set.seed(13)
students <- c(paste0("A",seq(1:38))) %>% factor()
n_students <- length(students)
n_occasions <- 11
#
n_memb_1 <- 4 # number of members in each of first set of groups
n_grps_1 <- 6 # number of groups in the first set
n_memb_2 <- 3 # number of members in each of second set of groups
n_grps_2 <- 2 # number of groups in the second set
#
# create sequences for groups and member sets
#
member_sets <- c(rep(1: n_memb_1, times = n_grps_1), rep(1:n_memb_2, times = n_grps_2))
group_sets <- c(rep(1:n_grps_1,each = n_memb_1), rep((n_grps_1+1):(n_grps_1 + n_grps_2),each = n_memb_2))
#
n_groups <- n_grps_1 + n_grps_2
#
# make vectors of leaders for all occasions and groups
#
leaders <- unlist(rep(students, ceiling(n_groups*n_occasions/n_students) ))[1:(n_occasions*n_groups)]
# make an empty tibble object to collect results
group_assign <- tibble()
#
# loop over occasions and collect results into group_assign
#
for( i_oc in 0:(n_occasions-1)) {
# get leaders for this occasion
occasion_leaders <- leaders[(i_oc*n_groups+1):((i_oc+1)*n_groups)]
# make list of students without leaders and randimize them
members <- setdiff(students, occasion_leaders) %>%
sample(n_students - n_groups)
# collect into tibble for this occasion and combine with other occasions
group_assign <- tibble(occasion = i_oc+1,
group = group_sets,
leader = occasion_leaders[group_sets],
member_number = member_sets,
member = members) %>%
bind_rows(group_assign)
}
#
# format for display
#
group_assign <- group_assign %>% arrange(occasion, group) %>%
pivot_wider(names_from = member_number,
values_from = member,
names_prefix = "Member_")
结果的前 10 行是：
# A tibble: 88 x 7
occasion group leader Member_1 Member_2 Member_3 Member_4
<dbl> <int> <fct> <chr> <chr> <chr> <chr>
1 1 A1 A32 A11 A13 A18
1 2 A2 A21 A14 A24 A30
1 3 A3 A12 A27 A25 A35
1 4 A4 A23 A36 A20 A9
1 5 A5 A33 A16 A26 A38
1 6 A6 A31 A34 A15 A22
1 7 A7 A28 A17 A37 NA
1 8 A8 A29 A19 A10 NA
2 1 A9 A38 A4 A2 A1
2 2 A10 A27 A32 A34 A30
我正在尝试为我的 class 创建一个时间表。 我有38个学生。我将在 11 (5+6) 次（BES 和 PBL）中与他们见面。
每次他们都被随机分为 8 组，结果是 6 组 5 人和 2 组 4 人。
对于每一个场合，我想选择一个学生来领导那个小组——一个领导者。我希望每个学生都当过一次小组组长。
我最多通过以下方式获得36个独特的领导者。 有没有办法 运行 在 R 中进行优化，以便我想要一个 objective 函数来最大化唯一领导者的数量？我的猜测是当前的限制是通过随机抽样分组的方式。
set.seed(13)
studentlist <- data.frame(Name=as.character(c(paste0("A",seq(1:38)))))
studentlist$PBL1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$PBL5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist$BES6 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),
labels=paste0(1:8)))
studentlist <- as.data.frame(studentlist)
BES_leaders <- studentlist %>% select(Name, BES1:BES6) %>% pivot_longer(cols = "BES1":"BES6",names_to = "Occassion",values_to = "Group")
#initiate i to count set.seed
i <- 1
#initialise best solution
BES_leaders3 <- data.frame()
while(length(unique(BES_leaders2$Leader))<=36) {
set.seed(i)
return.i <- i
BES_leaders_2 <- BES_leaders %>% nest_by(Occassion,Group) %>% mutate(Leader= sample(c(data$Name),1,replace = FALSE)) %>% select(Occassion,Group,Leader)
BES_leaders2 <- as.data.frame(BES_leaders_2)
BES_leaders3 <- if(length(unique(BES_leaders2$Leader)) > length(unique(BES_leaders3$Leader))){BES_leaders2} else {BES_leaders3}
i <- i+1
print(length(unique(BES_leaders3$Leader)))
}
这是一个简化的问题，将 5 名领导者分配到 10 组，每组 5 人，（每个人两次成为领导者）
m1 <- replicate(10, sample(1:5, 5)) #randomize 10 groups of 5
leaders <- c(1:5, 1:5) # create the leader top row
m2 <- rbind(leaders, m1) # bind the leader row to the random groups
m3 <- apply(m2, 2, unique) # remove the redundant leaders from each group
你会做同样的事情，但要针对 76 个小组的 38 名学生。然后简单地随机化剩余的 12 个组，任意分配领导者并将它们绑定到 m3。
我们可以将其表述为优化问题：
引入符号：
i : set of occasions (11)
s : set of students (38)
g : set of groups (8)
计算
gsi[g,s,i] = 1 if student s is in group g at occasion i
0 otherwise
this is calculated from your studentlist
定义变量：
leader[i,s] = 1 if student s is leader at occasion i
0 otherwise
countTimes[s] : number of times student s is a leader
max : max(countTimes[s])
min : min(countTimes[s])
构建模型：
minimize max - min
subject to
sum(s, gsi[g,s,i]*leader[i,s]) = 1 for all i,g
countTimes[s] = sum(i,leader[i,s])
countTimes[s] <= max for all s
countTimes[s] >= min for all s
对我来说：
---- 95 PARAMETER lead
A1 A2 A3 A4 A5 A6 A7 A8 A9
PBL2.group4 1
PBL3.group6 1
PBL4.group2 1
PBL4.group4 1
PBL4.group7 1
PBL5.group6 1
PBL5.group7 1
BES1.group1 1
BES1.group4 1
BES1.group8 1
BES2.group3 1
BES2.group4 1
BES3.group4 1
BES3.group7 1
BES4.group5 1
BES4.group6 1
BES4.group8 1
BES5.group1 1
BES5.group2 1
BES5.group3 1
BES6.group1 1
BES6.group6 1
+ A10 A11 A12 A13 A14 A15 A16 A17 A18
PBL1.group1 1
PBL1.group2 1
PBL1.group4 1
PBL1.group8 1
PBL2.group1 1
PBL2.group7 1
PBL3.group4 1
PBL5.group2 1
PBL5.group4 1
PBL5.group5 1
BES1.group7 1
BES2.group1 1
BES2.group5 1
BES4.group1 1
BES4.group4 1
BES5.group5 1
BES5.group8 1
BES6.group7 1
BES6.group8 1
+ A19 A20 A21 A22 A23 A24 A25 A26 A27
PBL1.group3 1
PBL1.group5 1
PBL2.group2 1
PBL2.group3 1
PBL2.group8 1
PBL3.group2 1
PBL3.group7 1
PBL4.group1 1
PBL4.group3 1
PBL4.group6 1
PBL5.group1 1
PBL5.group3 1
BES3.group1 1
BES3.group2 1
BES4.group3 1
BES4.group7 1
BES5.group4 1
BES5.group6 1
BES6.group2 1
BES6.group4 1
BES6.group5 1
+ A28 A29 A30 A31 A32 A33 A34 A35 A36
PBL1.group7 1
PBL2.group5 1
PBL2.group6 1
PBL3.group1 1
PBL3.group3 1
PBL4.group5 1
PBL4.group8 1
PBL5.group8 1
BES1.group2 1
BES1.group3 1
BES1.group5 1
BES1.group6 1
BES2.group2 1
BES2.group6 1
BES2.group7 1
BES2.group8 1
BES3.group5 1
BES3.group6 1
BES3.group8 1
BES4.group2 1
BES5.group7 1
+ A37 A38
PBL1.group6 1
PBL3.group5 1
PBL3.group8 1
BES3.group3 1
BES6.group3 1
每个学生都是领导者的两倍或三倍。我没有使用 R，而是使用商业工具。我会看看我是否可以在 R 中做到这一点。
R 实现可能如下所示：
library(dplyr)
library(ROI)
library(ROI.plugin.glpk)
library(ompr)
library(ompr.roi)
numStudents <- 38
numGroups <- 8
numMeetings <- 11
# code from question
set.seed(13)
studentlist <- data.frame(Name=as.character(c(paste0("A",seq(1:38)))))
studentlist$PBL1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$PBL5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES1 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES2 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES3 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES4 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES5 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist$BES6 <- sample(factor(rep(1:8, length.out=nrow(studentlist)),labels=paste0(1:8)))
studentlist <- as.data.frame(studentlist)
studentlist
# form 3d binary matrix
gsi <- array(0L,dim=c(numGroups,numStudents,numMeetings))
for (s in 1:numStudents)
for (i in 1:numMeetings) {
g <- studentlist[s,i+1]
gsi[g,s,i] = 1L
}
result <- MIPModel() %>%
add_variable(leader[i,s], i=1:numMeetings, s=1:numStudents, type = "binary") %>%
add_variable(count[s], s=1:numStudents) %>%
add_variable(max) %>%
add_variable(min) %>%
set_objective(max-min, "min") %>%
add_constraint(sum_expr(gsi[g,s,i]*leader[i,s], s=1:numStudents) == 1, i=1:numMeetings, g=1:numGroups) %>%
add_constraint(count[s] == sum_expr(leader[i,s], i=1:numMeetings), s=1:numStudents) %>%
add_constraint(count[s] <= max, s=1:numStudents) %>%
add_constraint(count[s] >= min, s=1:numStudents) %>%
add_constraint(min >= 1) %>%
# too slow to prove optimality. We stop after 200 seconds.
solve_model(with_ROI(solver="glpk", verbose=T, tm_limit=20000)) %>%
get_solution(leader[i,s]) %>%
filter(value > 0)
result2 <- matrix(0L,nrow=numStudents,ncol=numMeetings)
for (k in 1:nrow(result)) {
i <- result$i[k]
s <- result$s[k]
result2[s,i] <- 1
}
rownames(result2) <- studentlist$Name
colnames(result2) <- colnames(studentlist)[-1]
result2
求解器不够强大，无法证明最优性，但我们应该在（远）少于 200 秒的时间限制 (objective=1) 内找到最优解。 result2 输出如下所示：
> result2
PBL1 PBL2 PBL3 PBL4 PBL5 BES1 BES2 BES3 BES4 BES5 BES6
A1 0 1 0 1 0 0 1 0 0 0 0
A2 1 0 0 0 0 0 0 0 1 1 0
A3 0 0 1 0 0 0 0 1 0 1 0
A4 1 0 1 1 0 0 0 0 0 0 0
A5 1 0 0 0 1 0 0 1 0 0 0
A6 0 0 0 1 0 0 0 0 1 1 0
A7 0 0 0 0 0 0 1 1 1 0 0
A8 0 1 0 0 1 1 0 0 0 0 0
A9 1 0 0 0 1 0 0 0 0 0 0
A10 0 1 1 0 0 0 0 0 0 0 0
A11 0 0 1 0 0 0 0 1 0 0 0
A12 1 0 0 0 0 0 0 0 1 0 0
A13 0 0 0 1 0 1 0 0 0 0 0
A14 0 0 0 0 0 0 1 1 0 0 0
A15 0 0 0 0 0 0 0 0 1 0 1
A16 0 1 0 0 0 1 0 0 0 0 1
A17 0 1 0 0 1 0 0 0 0 0 0
A18 0 0 0 0 0 0 1 0 0 1 0
A19 0 0 0 0 1 0 0 0 0 1 0
A20 1 0 0 0 0 1 0 0 0 0 0
A21 0 0 0 0 0 0 1 0 0 0 1
A22 0 1 0 0 0 1 0 0 0 0 0
A23 0 0 0 0 0 0 0 0 0 1 1
A24 0 0 0 0 1 0 0 0 0 0 1
A25 0 0 0 0 0 1 0 0 0 0 1
A26 0 0 0 0 0 0 1 0 1 0 0
A27 0 0 1 0 0 0 0 1 0 0 0
A28 0 0 0 1 0 0 0 1 0 1 0
A29 1 0 0 0 0 0 0 0 0 0 1
A30 1 0 0 1 0 0 1 0 0 0 0
A31 0 0 0 0 0 1 0 1 0 0 0
A32 0 0 1 0 0 0 1 0 0 0 0
A33 0 0 1 0 0 0 0 0 1 0 0
A34 0 0 1 0 0 0 0 0 0 1 0
A35 0 1 0 0 1 0 0 0 1 0 0
A36 0 0 0 1 0 0 0 0 0 0 1
A37 0 1 0 0 0 1 0 0 0 0 0
A38 0 0 0 1 1 0 0 0 0 0 0
此解决方案遵循类似 SteveM 的方法，即按顺序将领导者分配给场合和小组。然而，它明确地处理了两个小组的规模，并在不同的小组和场合随机分配学生。它仅使用基础 R 和 tidyverse。所有学生都被指定为领导者两次或三次。
library(tidyverse)
set.seed(13)
students <- c(paste0("A",seq(1:38))) %>% factor()
n_students <- length(students)
n_occasions <- 11
#
n_memb_1 <- 4 # number of members in each of first set of groups
n_grps_1 <- 6 # number of groups in the first set
n_memb_2 <- 3 # number of members in each of second set of groups
n_grps_2 <- 2 # number of groups in the second set
#
# create sequences for groups and member sets
#
member_sets <- c(rep(1: n_memb_1, times = n_grps_1), rep(1:n_memb_2, times = n_grps_2))
group_sets <- c(rep(1:n_grps_1,each = n_memb_1), rep((n_grps_1+1):(n_grps_1 + n_grps_2),each = n_memb_2))
#
n_groups <- n_grps_1 + n_grps_2
#
# make vectors of leaders for all occasions and groups
#
leaders <- unlist(rep(students, ceiling(n_groups*n_occasions/n_students) ))[1:(n_occasions*n_groups)]
# make an empty tibble object to collect results
group_assign <- tibble()
#
# loop over occasions and collect results into group_assign
#
for( i_oc in 0:(n_occasions-1)) {
# get leaders for this occasion
occasion_leaders <- leaders[(i_oc*n_groups+1):((i_oc+1)*n_groups)]
# make list of students without leaders and randimize them
members <- setdiff(students, occasion_leaders) %>%
sample(n_students - n_groups)
# collect into tibble for this occasion and combine with other occasions
group_assign <- tibble(occasion = i_oc+1,
group = group_sets,
leader = occasion_leaders[group_sets],
member_number = member_sets,
member = members) %>%
bind_rows(group_assign)
}
#
# format for display
#
group_assign <- group_assign %>% arrange(occasion, group) %>%
pivot_wider(names_from = member_number,
values_from = member,
names_prefix = "Member_")
结果的前 10 行是：
# A tibble: 88 x 7
occasion group leader Member_1 Member_2 Member_3 Member_4
<dbl> <int> <fct> <chr> <chr> <chr> <chr>
1 1 A1 A32 A11 A13 A18
1 2 A2 A21 A14 A24 A30
1 3 A3 A12 A27 A25 A35
1 4 A4 A23 A36 A20 A9
1 5 A5 A33 A16 A26 A38
1 6 A6 A31 A34 A15 A22
1 7 A7 A28 A17 A37 NA
1 8 A8 A29 A19 A10 NA
2 1 A9 A38 A4 A2 A1
2 2 A10 A27 A32 A34 A30