如何在R中用线性规划实现满足多约束的评委-作品分配？

问题说明 #

需要将4位评委分配给15份作品，满足三个核心约束：

• 每份作品恰好由2位评委评分
• 每位评委评分的作品数量控制为7或8份（2位评7份，2位评8份）
• 任意两位评委共同评分的作品数量控制为2或3份

已通过lpSolve实现前两个约束，现在需要添加第三个约束的代码逻辑。

核心思路 #

要实现“任意两位评委共同评分作品数均等”，需要处理0-1变量的线性化转换：共同评分的作品数本质是“同时被两位评委选中的作品数量”，这是两个0-1变量的乘积（作品i被评委j1选中且被j2选中），而线性规划无法直接处理乘积。因此引入新的二进制变量y_ij表示“作品i是否被评委对(j1,j2)共同评分”，再通过线性约束关联y_ij与原变量x_ij（作品i是否被评委j选中）。

修改后的完整代码 #

library(lpSolve)
set.seed(144)

# 定义评委和作品
N <- c('T','E','S','J')
M <- 1:15

# 生成原变量（作品-评委）和新变量（作品-评委对）
judge_pairs <- combn(N, 2, simplify = FALSE)
x_vars <- expand.grid(i = M, j = N, type = "x")
y_vars <- expand.grid(i = M, pair = sapply(judge_pairs, paste, collapse = "-"), type = "y")
vars <- rbind(x_vars, y_vars)

# 构建约束矩阵
## 约束1：每份作品恰好2位评委评分
constraint1 <- t(sapply(M, function(i) {
  as.numeric(vars$type == "x" & vars$i == i)
}))

## 约束2：每位评委评分数量在7-8之间
constraint2_low <- t(sapply(N, function(j) {
  as.numeric(vars$type == "x" & vars$j == j)
}))
constraint2_high <- constraint2_low

## 约束3：y_ij ≤ x_i,j1（y只能在x1为1时为1）
constraint3 <- do.call(rbind, lapply(judge_pairs, function(pair) {
  j1 <- pair[1]
  lapply(M, function(i) {
    vec <- rep(0, nrow(vars))
    vec[which(vars$type == "y" & vars$i == i & vars$pair == paste(pair, collapse = "-"))] <- 1
    vec[which(vars$type == "x" & vars$i == i & vars$j == j1)] <- -1
    vec
  })
}))

## 约束4：y_ij ≤ x_i,j2（y只能在x2为1时为1）
constraint4 <- do.call(rbind, lapply(judge_pairs, function(pair) {
  j2 <- pair[2]
  lapply(M, function(i) {
    vec <- rep(0, nrow(vars))
    vec[which(vars$type == "y" & vars$i == i & vars$pair == paste(pair, collapse = "-"))] <- 1
    vec[which(vars$type == "x" & vars$i == i & vars$j == j2)] <- -1
    vec
  })
}))

## 约束5：y_ij ≥ x_i,j1 + x_i,j2 - 1（当x1和x2都为1时，y必须为1）
constraint5 <- do.call(rbind, lapply(judge_pairs, function(pair) {
  j1 <- pair[1]
  j2 <- pair[2]
  lapply(M, function(i) {
    vec <- rep(0, nrow(vars))
    vec[which(vars$type == "y" & vars$i == i & vars$pair == paste(pair, collapse = "-"))] <- 1
    vec[which(vars$type == "x" & vars$i == i & vars$j == j1)] <- -1
    vec[which(vars$type == "x" & vars$i == i & vars$j == j2)] <- -1
    vec
  })
}))

## 约束6：每对评委共同评分作品数≥2
constraint6 <- do.call(rbind, lapply(judge_pairs, function(pair) {
  as.numeric(vars$type == "y" & vars$pair == paste(pair, collapse = "-"))
}))

## 约束7：每对评委共同评分作品数≤3
constraint7 <- constraint6

# 合并所有约束
const.mat <- rbind(constraint1, constraint2_low, constraint2_high, constraint3, constraint4, constraint5, constraint6, constraint7)

# 设置约束方向和右侧值
const.dir <- c(
  rep("=", nrow(constraint1)),
  rep(">=", nrow(constraint2_low)),
  rep("<=", nrow(constraint2_high)),
  rep("<=", nrow(constraint3)),
  rep("<=", nrow(constraint4)),
  rep(">=", nrow(constraint5)),
  rep(">=", nrow(constraint6)),
  rep("<=", nrow(constraint7))
)

const.rhs <- c(
  rep(2, nrow(constraint1)),
  rep(7, nrow(constraint2_low)),
  rep(8, nrow(constraint2_high)),
  rep(0, nrow(constraint3)),
  rep(0, nrow(constraint4)),
  rep(-1, nrow(constraint5)),
  rep(2, nrow(constraint6)),
  rep(3, nrow(constraint7))
)

# 设置目标函数（用随机数避免退化，不影响可行解）
objective.in <- c(rnorm(nrow(x_vars)), rep(0, nrow(y_vars)))

# 求解线性规划
mod <- lp(direction = "max",
          objective.in = objective.in,
          const.mat = const.mat,
          const.dir = const.dir,
          const.rhs = const.rhs,
          all.bin = TRUE)

# 提取结果：每个评委负责的作品
x_sol <- vars[vars$type == "x" & mod$solution > 0.999, ]
judge_assignments <- sapply(N, function(j) x_sol$i[x_sol$j == j])
print(judge_assignments)

# 验证每对评委的共同作品数
pair_shared <- lapply(judge_pairs, function(pair) {
  works1 <- judge_assignments[[pair[1]]]
  works2 <- judge_assignments[[pair[2]]]
  length(intersect(works1, works2))
})
names(pair_shared) <- sapply(judge_pairs, paste, collapse = "-")
print(pair_shared)

代码说明 #

1. 变量扩展：新增y_ij变量，用于标记作品是否被某对评委共同评分
2. 约束关联：通过5组约束将y_ij与原变量x_ij绑定，确保y_ij准确反映共同评分状态
3. 范围约束：为每对评委添加共同作品数的上下限（2-3），同时保留原有的作品、评委数量约束
4. 结果验证：最后输出每对评委的共同作品数，确认是否满足要求

内容的提问来源于stack exchange，提问作者Hi_Viz