Algoritmi di corrispondenza in R (matching bipartito, algoritmo ungherese)

Question

Mi chiedo come impostare alcuni esempi di procedure di corrispondenza fondamentali in R. Ci sono molti esempi in vari linguaggi di programmazione, ma non ho ancora trovato un buon esempio per R.

Diciamo che voglio abbinare gli studenti a progetti e vorrei prendere in considerazione 3 approcci alternativi che mi sono imbattuto quando googling su questo tema:

1) caso di corrispondenza bipartito: chiedo a ogni studente per citarne 3 progetti a lavorare on (senza indicare alcuna preferenza tra quelle 3).

ID T.1 T.2 T.3 T.4 T.5 T.6 T.7 
1 1 1 1 0 0 0 0 
2 0 0 0 0 1 1 1 
3 0 1 1 1 0 0 0 
4 0 0 0 1 1 1 0 
5 1 0 1 0 1 0 0 
6 0 1 0 0 0 1 1 
7 0 1 1 0 1 0 0 

-

d.1 <- structure(list(Student.ID = 1:7, Project.1 = c(1L, 0L, 0L, 0L, 
1L, 0L, 0L), Project.2 = c(1L, 0L, 1L, 0L, 0L, 1L, 1L), Project.3 = c(1L, 
0L, 1L, 0L, 1L, 0L, 1L), Project.4 = c(0L, 0L, 1L, 1L, 0L, 0L, 
0L), Project.5 = c(0L, 1L, 0L, 1L, 1L, 0L, 1L), Project.6 = c(0L, 
1L, 0L, 1L, 0L, 1L, 0L), Project.7 = c(0L, 1L, 0L, 0L, 0L, 1L, 
0L)), .Names = c("Student.ID", "Project.1", "Project.2", "Project.3", 
"Project.4", "Project.5", "Project.6", "Project.7"), class = "data.frame", row.names = c(NA, 
-7L)) 

2) Algoritmo ungherese: chiedo a ogni nome studente 3 progetti su cui lavorare CON affermazione di una preferenza classifica tra quelli 3. Per quanto ho capito il ragionamento quando si applica il l'algoritmo in questo caso sarebbe qualcosa di simile: migliore è il grado più bassi sono i "costi" per lo studente.

ID T.1 T.2 T.3 T.4 T.5 T.6 T.7 
1 3 2 1 na na na na 
2 na na na na 1 2 3 
3 na 1 3 2 na na na 
4 na na na 1 2 3 na 
5 2 na 3 na 1 na na 
6 na 3 na na na 2 1 
7 na 1 2 na 3 na na 

-

d.2 <- structure(list(Student.ID = 1:7, Project.1 = structure(c(2L, 3L, 
3L, 3L, 1L, 3L, 3L), .Label = c("2", "3", "na"), class = "factor"), 
    Project.2 = structure(c(2L, 4L, 1L, 4L, 4L, 3L, 1L), .Label = c("1", 
    "2", "3", "na"), class = "factor"), Project.3 = structure(c(1L, 
    4L, 3L, 4L, 3L, 4L, 2L), .Label = c("1", "2", "3", "na"), class = "factor"), 
    Project.4 = structure(c(3L, 3L, 2L, 1L, 3L, 3L, 3L), .Label = c("1", 
    "2", "na"), class = "factor"), Project.5 = structure(c(4L, 
    1L, 4L, 2L, 1L, 4L, 3L), .Label = c("1", "2", "3", "na"), class = "factor"), 
    Project.6 = structure(c(3L, 1L, 3L, 2L, 3L, 1L, 3L), .Label = c("2", 
    "3", "na"), class = "factor"), Project.7 = structure(c(3L, 
    2L, 3L, 3L, 3L, 1L, 3L), .Label = c("1", "3", "na"), class = "factor")), .Names = c("Student.ID", 
"Project.1", "Project.2", "Project.3", "Project.4", "Project.5", 
"Project.6", "Project.7"), class = "data.frame", row.names = c(NA, 
-7L)) 

3) ??? approccio: questo dovrebbe essere più o meno collegato a (2). Tuttavia, penso che sia probabilmente un approccio migliore/più giusto (almeno nel contesto dell'esempio). Gli studenti non possono scegliere i progetti, nemmeno conoscono i progetti, ma hanno valutato le loro qualifiche (1 "non esistente" a 10 "livello professionale") rispetto a un certo skillset. Inoltre, il docente ha valutato lo skillset richiesto per ogni progetto. Oltre a (2), un primo passo sarebbe quello di calcolare una matrice di similarità e quindi di eseguire la procedura di ottimizzazione dall'alto.

PS: Programming Skills 
SK: Statistical Knowledge 
IE: Industry Experience 

ID PS SK IE 
1 10 9 8 
2 1 2 10 
3 10 2 5 
4 2 5 3 
5 10 2 10 
6 1 10 1 
7 5 5 5 

-

d.3a <- structure(list(Student.ID = 1:7, Programming.Skills = c(10L, 1L, 
10L, 2L, 10L, 1L, 5L), Statistical.knowlegde = c(9L, 2L, 2L, 
5L, 2L, 10L, 5L), Industry.Expertise = c(8L, 10L, 5L, 3L, 10L, 
1L, 5L)), .Names = c("Student.ID", "Programming.Skills", "Statistical.knowlegde", 
"Industry.Expertise"), class = "data.frame", row.names = c(NA, 
-7L)) 

-

T: Topic ID 
PS: Programming Skills 
SK: Statistical Knowledge 
IE: Industry Experience 

T PS SK IE 
1 10 5 1 
2 1 1 5 
3 10 10 10 
4 2 8 3 
5 4 3 2 
6 1 1 1 
7 5 7 2 

-

d.3b <- structure(list(Project.ID = 1:7, Programming.Skills = c(10L, 
1L, 10L, 2L, 4L, 1L, 5L), Statistical.Knowlegde = c(5L, 1L, 10L, 
8L, 3L, 1L, 7L), Industry.Expertise = c(1L, 5L, 10L, 3L, 2L, 
1L, 2L)), .Names = c("Project.ID", "Programming.Skills", "Statistical.Knowlegde", 
"Industry.Expertise"), class = "data.frame", row.names = c(NA, 
-7L)) 

Gradirei qualsiasi aiuto in attuazione di tali approcci 3 a R. Grazie.

AGGIORNAMENTO: Le seguenti domande sembrano essere legate, ma nessuno mostrano come risolverlo in R: https://math.stackexchange.com/questions/132829/group-membership-assignment-by-preferences-optimization-problem https://superuser.com/questions/467577/using-optimization-to-assign-by-preference

Answer 1

Ecco le possibili soluzioni utilizzando corrispondenza bipartita e l'algoritmo ungherese.

La mia soluzione proposta utilizzando l'abbinamento bipartito potrebbe non essere quello che hai in mente. Tutto il codice sotto riportato è un campione casuale per un numero specificato di iterazioni, dopo il quale almeno una soluzione sarà stata identificata. Ciò potrebbe richiedere un numero elevato di iterazioni e un lungo periodo con problemi di grandi dimensioni. Il codice seguente ha trovato tre soluzioni per il tuo problema di esempio entro 200 iterazioni.

matrix1 <- matrix(c(1, 1, 1, NA, NA, NA, NA, 
        NA, NA, NA, NA, 1, 1, 1, 
        NA, 1, 1, 1, NA, NA, NA, 
        NA, NA, NA, 1, 1, 1, NA, 
        1, NA, 1, NA, 1, NA, NA, 
        NA, 1, NA, NA, NA, 1, 1, 
        NA, 1, 1, NA, 1, NA, NA), nrow=7, byrow=TRUE) 

set.seed(1234) 

iters <- 200 

my.match <- matrix(NA, nrow=iters, ncol=ncol(matrix1)) 

for(i in 1:iters) { 

    for(j in 1:nrow(matrix1)) { 

      my.match[i,j] <- sample(which(matrix1[j,] == 1), 1) 

    } 
} 

n.unique <- apply(my.match, 1, function(x) length(unique(x))) 

my.match[n.unique==ncol(matrix1),] 

#  [,1] [,2] [,3] [,4] [,5] [,6] [,7] 
# [1,] 3 7 4 6 1 2 5 
# [2,] 1 7 4 5 3 6 2 
# [3,] 3 5 4 6 1 7 2 

Ecco il codice per l'algoritmo ungherese utilizzando il pacchetto clue e solve_LSAP() come suggerito @jackStinger.Per far funzionare questo lavoro ho dovuto sostituire le osservazioni mancanti e le ho sostituite arbitrariamente con 4. La persona 5 non ha ottenuto la sua prima scelta e la Persona 7 non ha ottenuto nessuna delle tre scelte.

library(clue) 

matrix1 <- matrix(c(3, 2, 1, 4, 4, 4, 4, 
        4, 4, 4, 4, 1, 2, 3, 
        4, 1, 3, 2, 4, 4, 4, 
        4, 4, 4, 1, 2, 3, 4, 
        2, 4, 3, 4, 1, 4, 4, 
        4, 3, 4, 4, 4, 2, 1, 
        4, 1, 2, 4, 3, 4, 4), nrow=7, byrow=TRUE) 

matrix1 

solve_LSAP(matrix1, maximum = FALSE) 

# Optimal assignment: 
# 1 => 3, 2 => 5, 3 => 2, 4 => 4, 5 => 1, 6 => 7, 7 => 6 

Ecco un link ad un sito che mostra come funziona l'algoritmo ungherese: http://www.wikihow.com/Use-the-Hungarian-Algorithm

EDIT: 5 giugno 2014

Ecco il mio primo tentativo di ottimizzare il terzo scenario. Assegnare casualmente ogni studente a un progetto, quindi calcolare il costo per quel set di incarichi. Il costo è calcolato trovando la differenza tra il set di abilità di uno studente e le abilità richieste dal progetto. I valori assoluti di tali differenze sono sommati per fornire un costo totale per i sette incarichi.

Qui di seguito ripeto il processo 10.000 volte e identifico quali di quei 10.000 risultati si traducono nel costo più basso.

Un approccio alternativo sarebbe quello di fare una ricerca esaustiva di tutti i possibili incarichi di progetto degli studenti.

Né la ricerca casuale né la ricerca esaustiva sono probabilmente ciò che avevate in mente. Tuttavia, il primo fornirà una soluzione ottimale approssimativa e il secondo fornirebbe una soluzione ottimale esatta.

Potrei tornare a questo problema più tardi.

students <- matrix(c(10, 9, 8, 
         1, 2, 10, 
        10, 2, 5, 
         2, 5, 3, 
        10, 2, 10, 
         1, 10, 1, 
         5, 5, 5), nrow=7, ncol=3, byrow=TRUE) 

projects <- matrix(c(10, 5, 1, 
         1, 1, 5, 
        10, 10, 10, 
         2, 8, 3, 
         4, 3, 2, 
         1, 1, 1, 
         5, 7, 2), nrow=7, ncol=3, byrow=TRUE) 

iters <- 10000 

# col = student, cell = project 
assignments <- matrix(NA, nrow=iters, ncol=nrow(students)) 

for(i in 1:iters) { 
     assignments[i,1:7] <- sample(7,7,replace=FALSE) 
} 

cost <- matrix(NA, nrow=iters, ncol=nrow(students)) 

for(i in 1:iters) { 

    for(j in 1:nrow(students)) { 

      student <- j 
      project <- assignments[i,student] 

      student.cost <- rep(NA,3) 

      for(k in 1:3) {  

       student.cost[k] <- abs(students[student,k] - projects[project,k]) 

      } 

      cost[i,j] <- sum(student.cost) 

    } 

} 


total.costs <- rowSums(cost) 

assignment.costs <- cbind(assignments, total.costs) 
head(assignment.costs) 

assignment.costs[assignment.costs[,8]==min(assignment.costs[,8]),] 

#     total.costs 
# [1,] 3 2 1 4 5 6 7   48 
# [2,] 3 2 1 6 5 4 7   48 
# [3,] 3 2 1 6 5 4 7   48 

# student 1, project 3, cost = 3 
# student 2, project 2, cost = 6 
# student 3, project 1, cost = 7 
# student 4, project 4, cost = 3 
# student 5, project 5, cost = 15 
# student 6, project 6, cost = 9 
# student 7, project 7, cost = 5 

3+6+7+3+15+9+5 

# [1] 48 

EDIT: 6 giugno 2014

Ecco la ricerca esaustiva. Ci sono solo 5040 possibili modi per assegnare progetti ai sette studenti. Questa ricerca restituisce quattro soluzioni ottimali:

students <- matrix(c(10, 9, 8, 
         1, 2, 10, 
        10, 2, 5, 
         2, 5, 3, 
        10, 2, 10, 
         1, 10, 1, 
         5, 5, 5), nrow=7, ncol=3, byrow=TRUE) 

projects <- matrix(c(10, 5, 1, 
         1, 1, 5, 
        10, 10, 10, 
         2, 8, 3, 
         4, 3, 2, 
         1, 1, 1, 
         5, 7, 2), nrow=7, ncol=3, byrow=TRUE) 

library(combinat) 

n <- nrow(students) 

assignments <- permn(1:n) 
assignments <- do.call(rbind, assignments) 
dim(assignments) 

# column of assignments = student 
# row of assignments = iteration 
# cell of assignments = project 

cost <- matrix(NA, nrow=nrow(assignments), ncol=n) 

for(i in 1:(nrow(assignments))) { 
    for(student in 1:n) { 

      project  <- assignments[i,student] 
      student.cost <- rep(NA,3) 

      for(k in 1:3) {  
       student.cost[k] <- abs(students[student,k] - projects[project,k]) 
      } 

      cost[i,student] <- sum(student.cost) 
    } 
} 


total.costs <- rowSums(cost) 

assignment.costs <- cbind(assignments, total.costs) 
head(assignment.costs) 

assignment.costs[assignment.costs[,(n+1)]==min(assignment.costs[,(n+1)]),] 

        total.costs 
[1,] 3 2 5 4 1 6 7   48 
[2,] 3 2 5 6 1 4 7   48 
[3,] 3 2 1 6 5 4 7   48 
[4,] 3 2 1 4 5 6 7   48