Créer des combinaisons dans R par groupes
Je veux créer une liste pour ma classe de chaque groupe possible de 4 élèves. Si j'ai 20 étudiants, comment puis-je créer cela, par groupe, dans R où mes lignes sont chaque combinaison et il y a 20 colonnes pour la liste complète des identifiants des étudiants et les colonnes 1-4 sont "groupe1", 5-9 sont "groupe2" etc. etc.
Ce qui suit donne une liste des combinaisons possibles pour chaque groupe de 4 élèves (x1, x2, x3 et x4). Maintenant, pour chaque ligne répertoriée, quelles sont les possibilités pour les 4 autres groupes de 4 élèves? Ainsi, il devrait y avoir 20 colonnes (Groupe1_1: 4, Groupe2_1: 4, Groupe3_1: 4, Groupe4_1: 4, Groupe5_1: 4).
combn(c(1:20), m = 4)
Sortie désirée
Combination 1 = Group1[1, 2, 3, 4] Group2[5, 6, 7, 8], Group3[9, 10, 11, 12], etc.
Combination 2 = Group1[1, 2, 3, 5]... etc.
Il y a beaucoup de messages sur les combinaisons, il est possible que cela soit déjà répondu et que je ne le trouve pas. Toute aide est appréciée!
Cela dépend fortement de cette réponse:
Algorithme qui peut créer toutes les combinaisons et tous les groupes de ces combinaisons
Une chose à noter est que la réponse n'est pas aussi dynamique - elle ne comprenait qu'une solution pour des groupes de 3. Pour le rendre plus robuste, nous pouvons créer le code en fonction des paramètres d'entrée. Autrement dit, la fonction récursive suivante est créée à la volée pour les groupes 3:
group <- function(input, step){
len <- length(input)
combination[1, step] <<- input[1]
for (i1 in 2:(len-1)) {
combination[2, step] <<- input[i1]
for (i2 in (i1+1):(len-0)) {
combination[3, step] <<- input[i2]
if (step == m) {
print(z); result[z, ,] <<- combination
z <<- z+1
} else {
rest <- setdiff(input, input[c(i1,i2, 1)])
group(rest, step +1) #recursive if there are still additional possibilities
}}
}
}
Cela prend environ 55 secondes pour s'exécuter pendant N = 16 et k = 4. Je voudrais le traduire en Rcpp mais malheureusement je n'ai pas cette compétence.
group_N <- function(input, k = 2) {
N = length(input)
m = N/k
combos <- factorial(N) / (factorial(k)^m * factorial(m))
result <- array(NA_integer_, dim = c(combos, m, k))
combination = matrix(NA_integer_, nrow = k, ncol = m)
z = 1
group_f_start = 'group <- function(input, step){\n len <- length(input) \n combination[1, step] <<- input[1] \n '
i_s <- paste0('i', seq_len(k-1))
group_f_fors = paste0('for (', i_s, ' in ', c('2', if (length(i_s) != 1) {paste0('(', i_s[-length(i_s)], '+1)')}), ':(len-', rev(seq_len(k)[-k])-1, ')) { \n combination[', seq_len(k)[-1], ', step] <<- input[', i_s, '] \n', collapse = '\n ')
group_f_inner = paste0('if (step == m) { \n result[z, ,] <<- combination \n z <<- z+1 \n } else { \n rest <- setdiff(input, input[c(',
paste0(i_s, collapse = ','),
', 1)]) \n group(rest, step +1) \n }')
eval(parse(text = paste0(group_f_start, group_f_fors, group_f_inner, paste0(rep('}', times = k), collapse = ' \n '))))
group(input, 1)
return(result)
}
Performances
system.time({test_1 <- group_N(seq_len(4), 2)})
# user system elapsed
# 0.01 0.00 0.02
library(data.table)
#this funky step is just to better show the groups. the provided
## array is fine.
as.data.table(t(rbindlist(as.data.table(apply(test_1, c(1,3), list)))))
# V1 V2
#1: 1,2 3,4
#2: 1,3 2,4
#3: 1,4 2,3
system.time({test_1 <- group_N(seq_len(16), 4)})
# user system elapsed
# 55.00 0.19 55.29
as.data.table(t(rbindlist(as.data.table(apply(test_1, c(1,3), list)))))
#very slow
# V1 V2 V3 V4
# 1: 1,2,3,4 5,6,7,8 9,10,11,12 13,14,15,16
# 2: 1,2,3,4 5,6,7,8 9,10,11,13 12,14,15,16
# 3: 1,2,3,4 5,6,7,8 9,10,11,14 12,13,15,16
# 4: 1,2,3,4 5,6,7,8 9,10,11,15 12,13,14,16
# 5: 1,2,3,4 5,6,7,8 9,10,11,16 12,13,14,15
# ---
#2627621: 1,14,15,16 2,11,12,13 3, 6, 9,10 4,5,7,8
#2627622: 1,14,15,16 2,11,12,13 3,7,8,9 4, 5, 6,10
#2627623: 1,14,15,16 2,11,12,13 3, 7, 8,10 4,5,6,9
#2627624: 1,14,15,16 2,11,12,13 3, 7, 9,10 4,5,6,8
#2627625: 1,14,15,16 2,11,12,13 3, 8, 9,10 4,5,6,7
Actuellement, cela est implémenté dans la version de développement de . Ceci est maintenant officiellement séparé de la version de production de RcppAlgos et sera dans la prochaine version officielle le CRAN RcppAlgos*.
library(RcppAlgos)
a <- comboGroups(10, numGroups = 2, retType = "3Darray")
dim(a)
[1] 126 5 2
a[1,,]
Grp1 Grp2
[1,] 1 6
[2,] 2 7
[3,] 3 8
[4,] 4 9
[5,] 5 10
a[126,,]
Grp1 Grp2
[1,] 1 2
[2,] 7 3
[3,] 8 4
[4,] 9 5
[5,] 10 6
Ou si vous préférez les matrices:
a1 <- comboGroups(10, 2, retType = "matrix")
head(a1)
Grp1 Grp1 Grp1 Grp1 Grp1 Grp2 Grp2 Grp2 Grp2 Grp2
[1,] 1 2 3 4 5 6 7 8 9 10
[2,] 1 2 3 4 6 5 7 8 9 10
[3,] 1 2 3 4 7 5 6 8 9 10
[4,] 1 2 3 4 8 5 6 7 9 10
[5,] 1 2 3 4 9 5 6 7 8 10
[6,] 1 2 3 4 10 5 6 7 8 9
C'est aussi très rapide. Vous pouvez même générer en parallèle avec nThreads ou Parallel = TRUE (ce dernier utilise un moins les threads max du système) pour des gains d'efficacité plus importants:
comboGroupsCount(16, 4)
[1] 2627625
system.time(comboGroups(16, 4, "matrix"))
user system elapsed
0.107 0.030 0.137
system.time(comboGroups(16, 4, "matrix", nThreads = 4))
user system elapsed
0.124 0.067 0.055
## 7 threads on my machine
system.time(comboGroups(16, 4, "matrix", Parallel = TRUE))
user system elapsed
0.142 0.126 0.047
Une fonctionnalité vraiment intéressante est la possibilité de générer des échantillons ou des groupes de combinaisons lexicographiques spécifiques, en particulier lorsque le nombre de résultats est élevé.
comboGroupsCount(factor(state.abb), numGroups = 10)
Big Integer ('bigz') :
[1] 13536281554808237495608549953475109376
mySamp <- comboGroupsSample(factor(state.abb),
numGroups = 10, "3Darray", n = 5, seed = 42)
mySamp[1,,]
Grp1 Grp2 Grp3 Grp4 Grp5 Grp`6 Grp7 Grp8 Grp9 Grp10
[1,] AL AK AR CA CO CT DE FL LA MD
[2,] IA AZ ME ID GA OR IL IN MS NM
[3,] KY ND MO MI HI PA MN KS MT OH
[4,] TX RI SC NH NV WI NE MA NY TN
[5,] VA VT UT OK NJ WY WA NC SD WV
50 Levels: AK AL AR AZ CA CO CT DE FL GA HI IA ID IL IN KS KY LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH ... WY
firstAndLast <- comboGroupsSample(state.abb, 10, "3Darray",
sampleVec = c("1",
"13536281554808237495608549953475109376"))
firstAndLast[1,,]
Grp1 Grp2 Grp3 Grp4 Grp5 Grp6 Grp7 Grp8 Grp9 Grp10
[1,] "AL" "CO" "HI" "KS" "MA" "MT" "NM" "OK" "SD" "VA"
[2,] "AK" "CT" "ID" "KY" "MI" "NE" "NY" "OR" "TN" "WA"
[3,] "AZ" "DE" "IL" "LA" "MN" "NV" "NC" "PA" "TX" "WV"
[4,] "AR" "FL" "IN" "ME" "MS" "NH" "ND" "RI" "UT" "WI"
[5,] "CA" "GA" "IA" "MD" "MO" "NJ" "OH" "SC" "VT" "WY"
firstAndLast[2,,]
Grp1 Grp2 Grp3 Grp4 Grp5 Grp6 Grp7 Grp8 Grp9 Grp10
[1,] "AL" "AK" "AZ" "AR" "CA" "CO" "CT" "DE" "FL" "GA"
[2,] "WA" "TX" "RI" "OH" "NM" "NE" "MN" "ME" "IA" "HI"
[3,] "WV" "UT" "SC" "OK" "NY" "NV" "MS" "MD" "KS" "ID"
[4,] "WI" "VT" "SD" "OR" "NC" "NH" "MO" "MA" "KY" "IL"
[5,] "WY" "VA" "TN" "PA" "ND" "NJ" "MT" "MI" "LA" "IN"
Et enfin, générer tout 2,546,168,625 des combinaisons de groupes de 20 personnes en 5 groupes (ce que l'OP demandait) peuvent être réalisées en moins d'une minute en utilisant les arguments lower et upper:
system.time(aPar <- parallel::mclapply(seq(1, 2546168625, 969969), function(x) {
combs <- comboGroups(20, 5, "3Darray", lower = x, upper = x + 969968)
### do something
dim(combs)
}, mc.cores = 6))
user system elapsed
217.667 22.932 48.482
sum(sapply(aPar, "[", 1))
[1] 2546168625
Bien que j'ai commencé à travailler sur ce problème il y a plus d'un an , cette question a été une énorme source d'inspiration pour que cela soit officialisé dans un package.
* Je suis l'auteur de RcppAlgos
C'est un problème de calcul difficile, car je pense qu'il y a 2,5 milliards de possibilités à énumérer. (En cas d'erreur, j'accueillerais volontiers tous les renseignements sur les points négatifs de cette approche.)
Selon la façon dont il est stocké, une table avec tous ces regroupements peut nécessiter plus RAM que la plupart des ordinateurs peuvent en gérer. Je serais impressionné de voir un moyen efficace de créer cela. Si nous prenions un " créer une combinaison à la fois ", il faudrait encore 41 minutes pour générer toutes les possibilités si nous pouvions générer 1 000 000 par seconde, ou un mois si nous ne pouvions en générer que 1 000 par seconde.
EDIT - ajout d'une implémentation partielle en bas pour créer tout regroupement souhaité de # 1 à # 2,546,168,625. À certaines fins, cela peut être presque aussi bon que de stocker la séquence entière, ce qui est très grand.
Disons que nous allons faire 5 groupes de quatre élèves chacun: Groupe A, B, C, D et E.
Définissons le groupe A comme le groupe d'étudiants n ° 1. Ils peuvent être jumelés avec trois des 19 autres étudiants. Je pense qu'il y a 969 combinaisons de ce type d'autres étudiants:
> nrow(t(combn(1:19, 3)))
[1] 969
Il reste maintenant 16 étudiants pour d'autres groupes. Affectons le premier élève qui ne fait pas déjà partie du groupe A au groupe B. Cela pourrait être l'élève 2, 3, 4 ou 5. Cela n'a pas d'importance; tout ce que nous devons savoir, c'est qu'il n'y a que 15 étudiants qui peuvent être jumelés avec cet étudiant. Il existe 455 combinaisons de ce type:
> nrow(t(combn(1:15, 3)))
[1] 455
Il reste maintenant 12 étudiants. Encore une fois, affectons le premier étudiant non groupé au groupe C, et il nous reste 165 combinaisons avec les 11 autres étudiants:
> nrow(t(combn(1:11, 3)))
[1] 165
Et il nous reste 8 étudiants, dont 7 peuvent être jumelés avec le premier étudiant non groupé dans le groupe D de 35 façons:
> nrow(t(combn(1:7, 3)))
[1] 35
Et puis, une fois nos autres groupes déterminés, il ne reste plus qu'un groupe de quatre étudiants, dont trois peuvent être jumelés avec le premier étudiant non groupé:
> nrow(t(combn(1:3, 3)))
[1] 1
Cela implique des combinaisons 2.546B:
> 969*455*165*35*1
[1] 2546168625
Voici une fonction de travail en cours qui produit un regroupement basé sur n'importe quel numéro de séquence arbitraire.
1) [en cours] Convertir le numéro de séquence en un vecteur décrivant la combinaison # à utiliser pour les groupes A, B, C, D et E. Par exemple, cela devrait convertir # 1 en c(1, 1, 1, 1, 1) et # 2 546 168 625 à c(969, 455, 165, 35, 1).
2) Convertissez les combinaisons en une sortie spécifique décrivant les élèves de chaque groupe.
groupings <- function(seq_nums) {
students <- 20
group_size = 4
grouped <- NULL
remaining <- 1:20
seq_nums_pad <- c(seq_nums, 1) # Last group always uses the only possible combination
for (g in 1:5) {
group_relative <-
c(1, 1 + t(combn(1:(length(remaining) - 1), group_size - 1))[seq_nums_pad[g], ])
group <- remaining[group_relative]
print(group)
grouped = c(grouped, group)
remaining <- setdiff(remaining, grouped)
}
}
> groupings(c(1,1,1,1))
#[1] 1 2 3 4
#[1] 5 6 7 8
#[1] 9 10 11 12
#[1] 13 14 15 16
#[1] 17 18 19 20
> groupings(c(1,1,1,2))
#[1] 1 2 3 4
#[1] 5 6 7 8
#[1] 9 10 11 12
#[1] 13 14 15 17
#[1] 16 18 19 20
> groupings(c(969, 455, 165, 35)) # This one uses the last possibility for
#[1] 1 18 19 20 # each grouping.
#[1] 2 15 16 17
#[1] 3 12 13 14
#[1] 4 9 10 11
#[1] 5 6 7 8
Voici un exemple pour les petits nombres. Je ne pense pas que cela évoluera bien pour 20 étudiants
total_students = 4
each_group = 2
total_groups = total_students/each_group
if (total_students %% each_group == 0) {
library(arrangements)
group_id = rep(1:total_groups, each = each_group)
#There is room to increase efficiency here by generating only relevant permutations
temp = permutations(1:total_students, total_students)
temp = unique(t(apply(temp, 1, function(i) {
x = group_id[i]
match(x, unique(x))
})))
dimnames(temp) = list(COMBO = paste0("C", 1:NROW(temp)),
Student = paste0("S", 1:NCOL(temp)))
} else {
cat("Total students not multiple of each_group")
temp = NA
}
#> Warning: package 'arrangements' was built under R version 3.5.3
temp
#> Student
#> COMBO S1 S2 S3 S4
#> C1 1 1 2 2
#> C2 1 2 1 2
#> C3 1 2 2 1
Créé le 2019-09-02 par le package reprex (v0.3.0)
Le nombre total de voies possibles est donné par la fonction suivante ( d'ici )
foo = function(N, k) {
#N is total number or people, k is number of people in each group
if (N %% k == 0) {
m = N/k
factorial(N)/(factorial(k)^m * factorial(m))
} else {
stop("N is not a multiple of n")
}
}
foo(4, 2)
#[1] 3
foo(20, 4)
#[1] 2546168625
Pour des groupes de 4 personnes sur un total de 20 personnes, le nombre d'arrangements possibles est énorme.
Ce code ci-dessous fonctionne.
# Create list of the 20 records
list <- c(1:20)
# Generate all combinations including repetitions
c <- data.frame(expand.grid(rep(list(list), 4))); rm(list)
c$combo <- paste(c$Var1, c$Var2, c$Var3, c$Var4)
# Remove repetitions
c <- subset(c, c$Var1 != c$Var2 & c$Var1 != c$Var3 & c$Var1 != c$Var4 & c$Var2 != c$Var3 & c$Var2 != c$Var4 & c$Var3 != c$Var4)
# Create common group labels (ex. abc, acb, bac, bca, cab, cba would all have "abc" as their group label).
key <- data.frame(paste(c$Var1, c$Var2, c$Var3, c$Var4))
key$group <- apply(key, 1, function(x) paste(sort(unlist(strsplit(x, " "))), collapse = " "))
c$group <- key$group; rm(key)
# Sort by common group label and id combos by group
c <- c[order(c$group),]
c$Var1 <- NULL; c$Var2 <- NULL; c$Var3 <- NULL; c$Var4 <- NULL;
c$rank <- rep(1:24)
# Pivot
c <- reshape(data=c,idvar="group", v.names = "combo", timevar = "rank", direction="wide")
Ainsi, vous pouvez obtenir toutes les combinaisons avec la fonction expand.grid En ajoutant simplement le vecteur de données quatre fois. Ensuite, le résultat aura des combinaisons comme c(1,1,1,1) donc je supprime chaque ligne qui a une valeur en double et la dernière partie fait juste les combinaisons. Il s'agit de 2 boucles et c'est assez lent mais il obtiendra ce que vous voulez. Cela pourrait être accéléré avec le package Rcpp. Le code est:
ids = 1:20
d2 = expand.grid(ids,ids,ids,ids)
## Remove rows with duplicated values
pos_use = apply(apply(d2,1,duplicated),2,function(x) all(x == F))
d2_temp = t(apply(d2[pos_use,],1,sort))
list_temp = list()
pos_quitar = NULL
for(i in 1:nrow(d2_temp)){
pos_quitar = c(pos_quitar,i)
ini_comb = d2_temp[i,]
d2_temp_use = d2_temp[-pos_quitar,]
temp_comb = ini_comb
for(j in 2:5){
pos_quitar_new = which(apply(d2_temp_use,1,function(x) !any(temp_comb%in%x)))[1]
temp_comb = c(temp_comb,d2_temp_use[pos_quitar_new,])
}
pos_quitar = c(pos_quitar,pos_quitar_new)
list_temp[[i]] = temp_comb
}
list_temp