Na dzisiejszych zajęciach będziemy testować bibliotekę matchingMarkets. Jeśli nie mamy biblioteki, należy ją oczywiście najpierw zainstalować z pomocą komendy.
install.packages("matchingMarkets")Jeśli biblioteka jest już zainstalowana, ładujemy ją poleceniem:
library(matchingMarkets)
rm(list=ls())Zaczniemy od podstawowej funkcji iaa.R ktora pozwoli nam porównać algorytm bostoński (tj. immediate-acceptance) z algorytmem Gale-Shapley’a. Podejrzyjmy najpierw funkcję iaa.
help(iaa)Pokazuje nam się pełny plik pomocy. Na razie najciekawsza dla nas jest składnia, która wygląda tak:
iaa(
nStudents = ncol(s.prefs),
nColleges = ncol(c.prefs),
nSlots = rep(1, nColleges),
s.prefs = NULL,
c.prefs = NULL,
acceptance = "immediate",
short_match = TRUE,
seed = NULL
)Resztę pomocy i przykłady możemy sobie pooglądać w oficjalnym podręczniku biblioteki matchingMarkets
Zacznijmy od najprostszego przykładu z losowymi preferencjami studentów. Funkcja set.seed pozwala na ustalenie ziarna generatora, a zatem pozwala, by losowe preferencje były te same dla obu algorytmów, które chcemy porównać.
Przyjmijmy, że chcemy dopasować 24 studentów do 3 uczelni, na każdej jest 6 miejsc. Dla ustalenia uwagi przyjmijmy, że każdy student woli być przypisany do niż nieprzypisany. Preferencje ustawią się losowo, ale wydrukujmy je.
set.seed(20)
boston <- iaa(nStudents=24, nSlots=c(6,6,6))
print(boston$s.prefs)## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14]
## [1,] 2 2 1 1 1 1 2 1 1 2 1 2 3 3
## [2,] 1 1 2 3 3 3 1 3 2 1 2 1 2 1
## [3,] 3 3 3 2 2 2 3 2 3 3 3 3 1 2
## [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24]
## [1,] 1 1 2 1 1 1 2 2 2 3
## [2,] 2 2 3 2 3 3 1 3 1 1
## [3,] 3 3 1 3 2 2 3 1 3 2print(boston$c.prefs)## [,1] [,2] [,3]
## [1,] 22 21 3
## [2,] 1 5 11
## [3,] 7 3 7
## [4,] 24 18 18
## [5,] 23 11 22
## [6,] 3 24 21
## [7,] 15 6 10
## [8,] 19 8 5
## [9,] 18 4 4
## [10,] 14 1 19
## [11,] 12 12 23
## [12,] 16 13 14
## [13,] 9 7 13
## [14,] 20 14 1
## [15,] 8 16 6
## [16,] 17 15 24
## [17,] 11 10 8
## [18,] 13 9 9
## [19,] 2 19 16
## [20,] 4 22 17
## [21,] 10 20 12
## [22,] 21 17 2
## [23,] 6 2 20
## [24,] 5 23 15Ostateczne dopasowanie
print(boston$matchings)## college student
## 1 1 3
## 6 1 9
## 2 1 15
## 5 1 16
## 4 1 18
## 3 1 19
## 8 2 1
## 10 2 7
## 11 2 10
## 9 2 12
## 7 2 21
## 12 2 22
## 17 3 4
## 16 3 5
## 18 3 6
## 14 3 13
## 13 3 14
## 15 3 24Kto się nie dostał do żadnej szkoły?
print(boston$singles)## [1] 2 8 11 17 20 23A ilu studentów - z tych, którzy się dostali - dostało się do szkoły pierwszego wyboru?
matchBoston <- data.frame(students=boston$matchings$student,college=boston$matchings$college)
boston$s.prefs[1,matchBoston$students]==matchBoston$college## [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [13] FALSE FALSE FALSE TRUE TRUE TRUEPorównajmy wyniki z algorytmem DA
set.seed(20)
deferredAcceptance <- iaa(nStudents=24, nSlots=c(6,6,6),acceptance = "deferred")
print(deferredAcceptance$s.prefs)## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14]
## [1,] 2 2 1 1 1 1 2 1 1 2 1 2 3 3
## [2,] 1 1 2 3 3 3 1 3 2 1 2 1 2 1
## [3,] 3 3 3 2 2 2 3 2 3 3 3 3 1 2
## [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24]
## [1,] 1 1 2 1 1 1 2 2 2 3
## [2,] 2 2 3 2 3 3 1 3 1 1
## [3,] 3 3 1 3 2 2 3 1 3 2print(deferredAcceptance$c.prefs)## [,1] [,2] [,3]
## [1,] 22 21 3
## [2,] 1 5 11
## [3,] 7 3 7
## [4,] 24 18 18
## [5,] 23 11 22
## [6,] 3 24 21
## [7,] 15 6 10
## [8,] 19 8 5
## [9,] 18 4 4
## [10,] 14 1 19
## [11,] 12 12 23
## [12,] 16 13 14
## [13,] 9 7 13
## [14,] 20 14 1
## [15,] 8 16 6
## [16,] 17 15 24
## [17,] 11 10 8
## [18,] 13 9 9
## [19,] 2 19 16
## [20,] 4 22 17
## [21,] 10 20 12
## [22,] 21 17 2
## [23,] 6 2 20
## [24,] 5 23 15Ostateczne dopasowanie
print(deferredAcceptance$matchings)## college student
## 1 1 3
## 4 1 7
## 2 1 15
## 3 1 19
## 6 1 23
## 5 1 24
## 8 2 1
## 10 2 6
## 11 2 8
## 12 2 11
## 9 2 18
## 7 2 21
## 17 3 4
## 16 3 5
## 18 3 10
## 14 3 13
## 13 3 14
## 15 3 22Kto się nie dostał do żadnej szkoły? Porównajmy:
# DA
print(deferredAcceptance$singles)## [1] 2 9 12 16 17 20# Boston
print(boston$singles)## [1] 2 8 11 17 20 23Teraz porównamy oba dopasowania. Żeby obraz porównania był pełen, dołączymy do tablicy dopasowań maturzystów, którzy nie dostali się na żadną uczelnię. Dla ustalenia uwagi, przypiszemy im numer uczelni 0.
matchBoston <- rbind(matchBoston,
data.frame(students=boston$singles,
college=rep(0,length(boston$singles)))
)
matchDA <- data.frame(students = c(deferredAcceptance$matchings$student,
deferredAcceptance$singles),
college = c(deferredAcceptance$matchings$college,
rep(0,length(deferredAcceptance$singles)))
)
matchDif <- data.frame(student=c(1:24),
colBoston = matchBoston[order(matchBoston$students),2],
colDA = matchDA[order(matchDA$students),2],
isSame = (matchDA[order(matchDA$students),2]==matchBoston[order(matchBoston$students),2]) )
print(matchDif)## student colBoston colDA isSame
## 1 1 2 2 TRUE
## 2 2 0 0 TRUE
## 3 3 1 1 TRUE
## 4 4 3 3 TRUE
## 5 5 3 3 TRUE
## 6 6 3 2 FALSE
## 7 7 2 1 FALSE
## 8 8 0 2 FALSE
## 9 9 1 0 FALSE
## 10 10 2 3 FALSE
## 11 11 0 2 FALSE
## 12 12 2 0 FALSE
## 13 13 3 3 TRUE
## 14 14 3 3 TRUE
## 15 15 1 1 TRUE
## 16 16 1 0 FALSE
## 17 17 0 0 TRUE
## 18 18 1 2 FALSE
## 19 19 1 1 TRUE
## 20 20 0 0 TRUE
## 21 21 2 2 TRUE
## 22 22 2 3 FALSE
## 23 23 0 1 FALSE
## 24 24 3 1 FALSEPrzyjrzyjmy się bliżej dopasowaniu bostońskiemu. Zauważmy, że agent 11 nie został nigdzie zrekrutowany. Ale jest on wysoko na liście preferencji uczelni 2 oraz 3. W szczególności, uczelnia 2 chętnie by wymieniła jednego ze swoich ‘ostatnich’ przyjętych studentów (np. 7, 10, 22) na studenta 11 i on również wolałby być przyjęty na uczelnię 2 niż nieprzyjęty. Również uczelnia 3 chętnie by wymieniła któregoś ze swoich przyjętych na ucznia nr 11. Jest to jeden z przykładów niestabilności mechanizmu bostońskiego.
Co więcej, zauważmy, że agent 11 (i nie tylko…) ma bodźce do strategicznego “kłamstwa” na temat swoich preferencji. Jego prawdziwe preferencje to \(1,2,3\). Sprawdźmy co by się stało, gdyby - wiedząc, że na uczelni 3 ma bardzo duże szanse przyjęcia - przedstawił je jako \(3,1,2\).
s.prefsNew <- boston$s.prefs
s.prefsNew[,11] <- c(3,1,2)
c.prefsNew <- boston$c.prefs
nSlotsNew <- c(6,6,6)Przy okazji przetestujemy podstawową funkcjonalność biblioteki, czyli konstrukcję dopasowań dla zadanych preferencji. W zastosowaniach jest to oczywiście ‘standardowe’ zastosowanie algorytmu.
Porównajmy, jak wygląda teraz dopasowanie według obu algorytmów.
bostonNew <- iaa(s.prefs=s.prefsNew, c.prefs=c.prefsNew, nSlots = nSlotsNew, acceptance="immediate")
deferredAcceptanceNew <- iaa(s.prefs=s.prefsNew, c.prefs=c.prefsNew, nSlots = nSlotsNew, acceptance="deferred")print(data.frame(boston=bostonNew$matching,DA=deferredAcceptanceNew$matching))## boston.college boston.student DA.college DA.student
## 1 1 3 1 3
## 6 1 9 1 7
## 2 1 15 1 15
## 5 1 16 1 19
## 4 1 18 1 23
## 3 1 19 1 24
## 8 2 1 2 1
## 10 2 7 2 6
## 11 2 10 2 8
## 9 2 12 2 12
## 7 2 21 2 18
## 12 2 22 2 21
## 18 3 4 3 4
## 17 3 5 3 5
## 13 3 11 3 10
## 15 3 13 3 11
## 14 3 14 3 14
## 16 3 24 3 22Zauważmy, że kłamstwo nt. swoich preferencji poprawiło sytuację gracza 11 przy mechanizmie bostońskim, ale pogorszyło przy deferred–aceptance. Dlaczego? Przy DA gracz 11 był wystarczająco dobry by dostać się do uczelni numer 2, która jest wyżej w jego prawdziwych preferencjach. Zgodnie z działaniem algorytmu DA uczeń dostaje się do najlepszej uczelni, do jakiej może, a więc kłamstwo nt. preferencji w najepszym wypadku nie zmieni dopasowania, a w niektórych przypadkach – jak tu - pogorszy sytuację.