Dopasowywanie algorytmów w R (dopasowanie bierne, węgierski algorytm)

Question

Zastanawiam się, jak ustawić przykład niektórych podstawowych procedur dopasowywania w R. Istnieje wiele przykładów w różnych językach programowania, ale nie znalazłem jeszcze dobrego przykładu dla R.

Powiedzmy, że chcemy, aby dopasować studentów do projektów i uważam 3 alternatywne podejścia, które natknąłem się podczas googlowania na ten temat:

1) dwustronny pokrowiec pasujący: pytam każdego ucznia, aby wymienić 3 projekty do pracy na (bez określania jakiegokolwiek rankingu preferencji spośród tych 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) algorytm węgierski: Pytam każdy napis student 3 projekty do pracy z podaniem preferencji ranking wśród tych 3. O ile dobrze zrozumiałem rozumowanie kiedy nałożeniem algorytm w tym przypadku byłby mniej więcej taki: im wyższa ranga, tym niższe "koszty" dla ucznia.

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) ??? podejście: Powinno to być prawie związane z (2). Uważam jednak, że jest to prawdopodobnie lepsze/bardziej sprawiedliwe podejście (przynajmniej w kontekście przykładu). Studenci nie mogą wybierać projektów, nawet nie wiedzą o projektach, ale ocenili swoje kwalifikacje (1 "nie istnieje" na 10 "poziomie zawodowym") w odniesieniu do określonego zestawu umiejętności. Ponadto, wykładowca ocenił wymagany zestaw umiejętności dla każdego projektu. Oprócz (2), pierwszym krokiem byłoby obliczenie macierzy podobieństwa, a następnie uruchomienie procedury optymalizacji z góry.

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

Będę wdzięczny za każdą pomoc w realizacji tych 3 podejścia w R. dziękuję.

UPDATE: następujące pytania wydają się być związane, ale nie pokazują, jak go rozwiązać w 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

Oto możliwe rozwiązania wykorzystujące dwustronnego dopasowania i algorytm węgierski.

Moje proponowane rozwiązanie przy użyciu dopasowywania dwustronnego może nie być tym, co masz na myśli. Cały poniższy kod jest próbkowany losowo dla określonej liczby iteracji, po czym zostanie znalezione co najmniej jedno rozwiązanie. Może to wymagać dużej liczby iteracji i długiego czasu z dużymi problemami. Poniższy kod znalazł trzy rozwiązania Twojego przykładowego problemu w ciągu 200 iteracji.

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 

Oto kod dla algorytmu węgierskiego wykorzystaniem pakietu clue i solve_LSAP() jak sugeruje @jackStinger.Aby to działało, musiałem zastąpić brakujące spostrzeżenia i zastąpiłem je arbitralnie 4. Osoba 5 nie otrzymała pierwszego wyboru, a osoba 7 nie otrzymała żadnego z tych trzech wyborów.

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 

Oto link do strony pokazując jak działa algorytm węgierski: http://www.wikihow.com/Use-the-Hungarian-Algorithm

EDIT: 05 czerwca 2014

Oto mój Pierwszy etap optymalizacji trzeci scenariusz. Losowo przypisuję każdego ucznia do projektu, a następnie obliczam koszt tego zestawu zadań. Koszt jest obliczany poprzez znalezienie różnicy między zestawem umiejętności ucznia a wymaganymi umiejętnościami projektu. Wartości bezwzględne tych różnic sumuje się, aby uzyskać całkowity koszt siedmiu zadań.

Poniżej powtarzam proces 10 000 razy i ustal, który z tych 10 000 przydziałów ma najniższy koszt.

Alternatywnym podejściem byłoby wykonanie wyczerpującego wyszukiwania wszystkich możliwych projektów uczniów-projektów.

Ani przypadkowe wyszukiwanie, ani wyczerpujące wyszukiwanie prawdopodobnie nie miało na myśli. Jednak pierwsze da przybliżone optymalne rozwiązanie, a drugie da dokładne optymalne rozwiązanie.

Mogę wrócić do tego problemu później.

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: 06 czerwiec 2014

Oto wyczerpująca wyszukiwania. Istnieje tylko 5040 możliwych sposobów przydzielania projektów siedmiu uczniom. To wyszukiwanie zwraca cztery optymalne rozwiązania:

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