主页 / coding / 问题 / 79187118
Accepted
L Tyrone
Asked: 2024-11-14 09:16:57 +0800 CST

将学生从人数不均等的组重新分配到人数相对均等的组，同时设置另外两个约束

  • 772

我想将 2024 年队列中的学生（n=105，女性=61，男性=44）分成 2025 年的小组。我希望实现的分布（按重要性排序）：

  1. 2024 届学生中最多有两名学生可以转入同一 2025 届
  2. 2025 个小组必须尽可能保持性别平衡，因此每个小组大约有 7 或 8 名女性和 5 或 6 名男性
  3. 2025 组大小必须尽可能均匀，理想情况下为 7 x 13 和 1 x 14
  4. 在可能的情况下，分配应该是随机的

鉴于如果严格遵守标准 1-3，可能无法找到解决方案，因此在组大小和随机性方面存在一些灵活性。

2024 年各团体的规模和性别平衡相对不均衡：

table(df[, c("Gender", "g2024")])
#         g2024
# Gender   1 2 3 4 5 6 7 8
#   Female 7 7 7 7 9 7 9 8
#   Male   4 4 8 6 5 7 4 6

table(df[, "g2024"])
# g2024
#  1  2  3  4  5  6  7  8 
# 11 11 15 13 14 14 13 14

使用预定值，这是我试图实现的一个基本示例：

# Create random vector with group ids for females per group, assign to g2025
set.seed(42)
grp_fem <- as.character(rep(1:8, sample(c(rep(7, 3), rep(8, 5)), 8)))

df$g2025 <- unlist(lapply(1:nrow(df), function(i) {  
  if (df$Gender[i] == "Female") {
    x <- sample(grp_fem, 1)
    grp_fem <<- grp_fem[-match(x, grp_fem)]
    return(x)
  } else { 
    return(NA)    
  }
}))

# Get males per group, change one group length so y sums to male count
x <- as.integer(table(df$g2025))
y <- 13 - x
z <- sample(which(y == 5), 1)
y[z] <- 6

# Create vector with group ids for males per group, assign to g2025
grp_mal <- as.character(rep(1:8, rep(y)))

df$g2025 <- unlist(lapply(1:nrow(df), function(i) {
  if (df$Gender[i] == "Male") {
    x <- sample(grp_mal, 1)
    grp_mal <<- grp_mal[-match(x, grp_mal)]
    return(x)   
  } else {
    return(df$g2025[i])  
  }
}))

# Gender distribution per group
table(df[, c("Gender", "g2025")])
#         g2025
# Gender   1 2 3 4 5 6 7 8
#   Female 7 8 8 8 7 8 7 8
#   Male   6 5 5 5 6 6 6 5

# Number of students carried from g2024 to g2025 groups
table(df[, c("g2024", "g2025")])
#      g2025
# g2024 1 2 3 4 5 6 7 8
#     1 0 2 1 2 1 2 3 0
#     2 1 3 2 2 0 0 1 2
#     3 2 2 1 2 3 2 1 2
#     4 1 1 2 1 2 2 2 2
#     5 2 1 4 0 2 3 1 1
#     6 5 3 1 2 0 0 2 1
#     7 1 1 0 1 2 2 1 5
#     8 1 0 2 3 3 3 2 0

预先确定的组大小和性别分布值显然并不理想，并且它没有考虑到有多少来自给定 2024 组的学生最终会分入同一个 2025 组。

我尝试使用一个组间分配基本随机分布的矩阵：

m <- structure(c(1, 1, 2, 1, 2, 2, 2, 2, 1, 1, 2, 2, 2, 2, 2, 1, 2, 
                 1, 2, 2, 2, 1, 1, 2, 1, 1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 1, 2, 2, 
                 1, 2, 1, 2, 2, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 2, 2, 1, 2, 2, 2, 
                 1, 2, 2, 1, 2), dim = c(8L, 8L))

rowSums(m)
# [1] 11 11 15 13 14 14 13 14
colSums(m)
# [1] 13 13 13 13 13 13 13 14

但这还需要预定义colSums()值和一些手动操作。我怀疑该lpSolve包可能能够处理这样的事情，但我不明白如何使用它。

数据：

df <- structure(list(Student = c("1", "2", "3", "4", "5", "6", "7", 
"8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", 
"19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", 
"30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", 
"41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", 
"52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "62", 
"63", "64", "65", "66", "67", "68", "69", "70", "71", "72", "73", 
"74", "75", "76", "77", "78", "79", "80", "81", "82", "83", "84", 
"85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", 
"96", "97", "98", "99", "100", "101", "102", "103", "104", "105"
), Gender = c("Female", "Male", "Male", "Male", "Female", "Female", 
"Male", "Female", "Female", "Female", "Male", "Male", "Male", 
"Female", "Male", "Female", "Male", "Female", "Female", "Female", 
"Male", "Male", "Female", "Female", "Female", "Male", "Male", 
"Male", "Female", "Female", "Male", "Female", "Female", "Female", 
"Male", "Female", "Female", "Female", "Female", "Male", "Male", 
"Female", "Female", "Female", "Female", "Male", "Female", "Male", 
"Female", "Female", "Female", "Female", "Male", "Female", "Male", 
"Female", "Male", "Male", "Male", "Female", "Female", "Female", 
"Female", "Female", "Female", "Male", "Female", "Female", "Male", 
"Male", "Female", "Female", "Male", "Female", "Male", "Female", 
"Female", "Male", "Female", "Female", "Female", "Male", "Female", 
"Male", "Female", "Female", "Male", "Female", "Male", "Male", 
"Male", "Male", "Male", "Female", "Male", "Female", "Female", 
"Male", "Female", "Male", "Female", "Female", "Male", "Male", 
"Female"), g2024 = c("4", "3", "3", "8", "2", "8", "4", "5", 
"8", "7", "2", "4", "4", "6", "6", "5", "1", "3", "7", "2", "6", 
"8", "2", "8", "1", "5", "8", "3", "3", "1", "5", "5", "1", "3", 
"8", "6", "1", "7", "5", "5", "1", "7", "4", "7", "5", "4", "8", 
"6", "3", "1", "7", "8", "7", "7", "2", "4", "8", "3", "7", "1", 
"6", "3", "6", "8", "2", "3", "3", "5", "7", "2", "2", "2", "8", 
"6", "1", "1", "4", "1", "6", "8", "2", "6", "5", "2", "5", "3", 
"3", "7", "3", "4", "3", "4", "7", "4", "6", "8", "4", "6", "6", 
"6", "5", "4", "5", "5", "7"), g2025 = c(NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
NA, NA, NA, NA)), row.names = c(NA, -105L), class = c("tbl_df", 
"tbl", "data.frame"))

1 个回答

  1. Best Answer

    我认为lpSolve这行不通，因为它需要线性函数，而我认为这必须是非线性的。来自生产和物流数据科学的优化包表没有显示任何可以处理非线性离散优化问题的 R 包，老实说，那里链接的更全面的列表让我感到害怕。

    然而，这让我想到了模拟退火的完美应用，因此我实现了维基百科页面上给出的简单模拟退火算法。

    anneal <- function(
    # initial state
    s0, 
    # energy function
    E, 
    # neighborhood function
    neighbor, 
    # cooling schedule
    temperature = function(r) Tmax * r ^ Tpwr, 
    # acceptance probability function
    #   default from Kirkpatrick et al. (1983)
    #   https://doi.org/10.1126%2Fscience.220.4598.671
    P = function(Eo, En, t) if (En < Eo) 1 else exp(-(En-Eo)/t), 
    # no. of iterations
    kmax = 1000,
    # initial temp. and shape of curve; not used if temperature is specified
    Tmax = 1, Tpwr = 1
  ) {
  
  # line-for-line pseudocode from Wikipedia, translated to R
  s <- s0
  for(k in 1:kmax) {
    t <- temperature(1-(k-1)/kmax)
    sn <- neighbor(s)
    if (P(E(s), E(sn), t) >= runif(1)) 
      s <- sn
  }
  return(s)
}

    在我看来，这比弄清楚如何使用新包更容易，而且无论如何我们仍然需要完成定义优化函数的下一部分：

    library(dplyr)
# Energy function (i.e. cost function i.e. optimization function)
cost <- function(s) {
  df2 <- df
  df2$g2025 <- s
  # "1. no more than two students from a 2024 group can carry over to the same
  #   2025 group"
  # Cost: 0 if 2 or fewer students from same group, 1 if 3, increases by square
  #   beyond 3
  cost1 <- sum(
    pmax(0, summarize(df2, nsame = max(table(g2024)), .by = g2025)$nsame-2)^2
  )
  # "2. 2025 groups must be as gender-balanced as possible, so something like 7 
  #   or 8 females and 5 or 6 males per group"
  # Cost: Square of difference between group gender proportion and overall
  #   gender proportion
  cost2 <- sum((
    summarize(df2, pfem = mean(Gender == "Female"), .by = g2025)$pfem -
    mean(df2$Gender == "Female")
  )^2)
  # return linear combination of cost 1 and cost 2
  # weights can be tuned to improve results
  return(1 * cost1 + 10 * cost2)
}

# neighborhood function
# swaps to students at random
# preserves equal group sizes
neighbor.swap <- function(s) {
  swap <- sample(1:length(s), 2)
  s[`[<-`(1:length(s), swap, rev(swap))]
}

# Initial state, satisfies requirement #4 of randomness
s0 <- rep_len(unique(df$g2024), length.out = nrow(df)) |>
  sample(nrow(df))

    然后我们可以运行模拟退火（通过反复试验找到参数）：

    # run simulated annealing
set.seed(8675309)
df$g2025 <- anneal(
  s0 = s0,
  E = cost,
  neighbor = neighbor.swap,
  kmax = 2500,
  Tmax = 2,
  Tpwr = 2
)

    看看它的表现如何：

    table(df[, c("g2024", "g2025")])

#>      g2025
#> g2024 1 2 3 4 5 6 7 8
#>     1 0 1 2 1 1 2 2 2
#>     2 2 1 1 2 1 1 1 2
#>     3 2 2 2 2 1 2 2 2
#>     4 2 1 1 2 2 2 1 2
#>     5 1 2 1 2 2 2 2 2
#>     6 2 2 2 2 2 1 2 1
#>     7 2 2 2 1 2 2 1 1
#>     8 2 2 2 2 2 1 2 1

table(df[, c("Gender", "g2025")])

#>         g2025
#> Gender   1 2 3 4 5 6 7 8
#>   Female 8 8 7 8 8 8 7 7
#>   Male   5 5 6 6 5 5 6 6

table(df[, c("g2025")])

#> g2025
#>  1  2  3  4  5  6  7  8 
#> 13 13 13 14 13 13 13 13

    从这些表格中，我们可以看到标准 1-3 分别得到满足。从技术上讲，这种方法赋予标准 3 比标准 1 或标准 2 更高的优先级，但由于所有标准都得到满足，因此这些数据并不重要，如果确实重要，则很容易改变这一点。至于标准 4，分组是随机的，因为初始猜测是随机的，邻里行走也是随机的（尽管是引导的）。



    作为脚注，这里有一个anneal带有打印诊断信息选项的版本：

    anneal <- function(
    s0, 
    E, 
    neighbor, 
    temperature = function(r) Tmax * r ^ Tpwr, 
    P = function(Eo, En, t) if (En < Eo) 1 else exp(-(En-Eo)/t), 
    kmax = 1000,
    Tmax = 1,
    Tpwr = 1,
    verbose = TRUE
  ) {
  
  s <- s0
  if (verbose) Es <- numeric(kmax)
  for(k in 1:kmax) {
    t <- temperature(1-(k-1)/kmax)
    sn <- neighbor(s)
    if (verbose) Es[k] <- E(s)
    if (verbose) message(
      "Iteration: ", k, "\n",
      "Temperature: ", t, "\n",
      "Energy: ", E(s), "\n"
    )
    if (P(E(s), E(sn), t) >= runif(1)) s <- sn
  }
  
  if (verbose) plot(
    x = 1:kmax, 
    y = Es, 
    type = "l",
    xlab = "Iteration",
    ylab = "Energy",
    main = "Convergence plot"
  )
  
  return(s)
}

    诊断模拟退火的收敛图

    • 1

相关问题