Adicionar número de série para atividade de cópia ao blob

Question

L Tyrone

Asked: 2024-11-14 09:16:57 +0800 CST2024-11-14 09:16:57 +0800 CST 2024-11-14 09:16:57 +0800 CST

Redistribuir alunos de grupos de tamanhos desiguais para grupos de tamanhos relativamente uniformes com duas outras restrições

772

Quero designar alunos da coorte de 2024 (n=105, mulheres=61, homens=44) em grupos para 2025. A distribuição que espero alcançar (em ordem de importância):

não mais do que dois alunos de um grupo de 2024 podem ser transferidos para o mesmo grupo de 2025
Os grupos de 2025 devem ser o mais equilibrados possível em termos de gênero, algo como 7 ou 8 mulheres e 5 ou 6 homens por grupo
Os tamanhos dos grupos de 2025 devem ser o mais uniformes possível, idealmente 7 x 13 e 1 x 14
sempre que possível, a distribuição deve ser aleatória

Dado que uma solução pode não ser possível se os critérios 1 a 3 forem rigorosamente respeitados, há alguma flexibilidade em relação ao tamanho do grupo e à aleatoriedade.

Os tamanhos e o equilíbrio de gênero para os grupos de 2024 são relativamente desiguais:

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

Usando valores pré-determinados, um exemplo rudimentar do que estou tentando alcançar:

# 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

Os tamanhos de grupo predeterminados e os valores de distribuição de gênero obviamente não são ideais e não levam em conta quantos alunos de um determinado grupo de 2024 acabarão no mesmo grupo de 2025.

Tentei usar uma matriz com uma distribuição quase aleatória de alocação de grupo para grupo:

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

mas isso também requeria colSums()valores predefinidos e alguma manipulação manual. Suspeito que o lpSolvepacote pode ser capaz de lidar com algo assim, mas não consegui entender como usá-lo.

Dados:

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 respostas

Voted

Eonema · Answer 1 · 2024-11-14T14:04:09+08:00

Não acho que lpSolvefuncionaria aqui porque requer uma função linear, enquanto acho que isso terá que ser não linear. Esta tabela de pacotes de otimização da Data Science for Production and Logistics não mostra nenhum pacote R que possa lidar com problemas de otimização discretos e não lineares, e para ser honesto, a lista mais abrangente vinculada lá me assusta.

No entanto, isso me parece uma aplicação perfeita para recozimento simulado, então implementei o algoritmo simples de recozimento simulado fornecido na página da Wikipedia .

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)
}

Mais fácil do que descobrir como usar um novo pacote, na minha opinião, e ainda precisaríamos fazer a próxima parte de definir a função de otimização:

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))

Então podemos executar o recozimento simulado (com parâmetros encontrados por tentativa e erro):

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

E veja como foi:

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

A partir dessas tabelas, podemos ver que os critérios 1-3, respectivamente, são satisfeitos. Tecnicamente, essa abordagem dá maior prioridade ao #3 do que ao #1 ou #2, mas como todos são satisfeitos, isso não importa para esses dados, e seria simples mudar isso se importasse. Quanto ao critério #4, os agrupamentos são aleatórios, na medida em que o palpite inicial foi aleatório e a caminhada pela vizinhança foi aleatória (embora guiada).

E como nota de rodapé, aqui está uma versão annealcom uma opção para imprimir informações de diagnóstico:

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)
}

Redistribuir alunos de grupos de tamanhos desiguais para grupos de tamanhos relativamente uniformes com duas outras restrições

Vue 3: Erro na criação "Identificador esperado, mas encontrado 'import'" [duplicado]

Por que esse código Java simples e pequeno roda 30x mais rápido em todas as JVMs Graal, mas não em nenhuma JVM Oracle?

Qual é o propósito de `enum class` com um tipo subjacente especificado, mas sem enumeradores?

Como faço para corrigir um erro MODULE_NOT_FOUND para um módulo que não importei manualmente?

`(expression, lvalue) = rvalue` é uma atribuição válida em C ou C++? Por que alguns compiladores aceitam/rejeitam isso?

Quando devo usar um std::inplace_vector em vez de um std::vector?

Um programa vazio que não faz nada em C++ precisa de um heap de 204 KB, mas não em C

PowerBI atualmente quebrado com BigQuery: problema de driver Simba com atualização do Windows

AdMob: MobileAds.initialize() - "java.lang.Integer não pode ser convertido em java.lang.String" para alguns dispositivos

Estou tentando fazer o jogo pacman usando apenas o módulo Turtle Random e Math

Redistribuir alunos de grupos de tamanhos desiguais para grupos de tamanhos relativamente uniformes com duas outras restrições

1 respostas

relate perguntas