Evidenţierea şi modelarea cuplajelor

În [1] am depistat cuplajele existente în orarul original, dar le-am folosit doar când am ajustat (interactiv) repartizarea pe zile furnizată de "distribute_by_days.R"; dacă vrem să ţinem cont de ele chiar în cadrul programului – iar aici, vizăm programul din [2], pentru repartizarea pe orele zilei a lecţiilor distribuite într-o aceeaşi zi – atunci trebuie ceva mai mult decât să le evidenţiem.

Următorul program evidenţiază cuplajele (reluând din [1], cu mici îmbunătăţiri) şi constituie anumite structuri de date cu informaţii privitoare la cuplaje (pe care le vom angaja mai târziu în "daySchoolSchedule.R").

# cuplaje.R
library(tidyverse)
lmk <- readRDS("orar_norm.RDS") %>%  # orarul iniţial (normalizat), din [1]
       mutate(prof = tolower(prof))  # 'p25' este mai lizibil ca 'P25'
## A tibble: 884 x 4  # (884 de lecţii $prof|$cls, unele fiind cuplate)
#  prof  zi      ora cls  
#  <ord> <chr>    <int> <chr>
#1 p01   Lu        5 10A    # (cuplat cu 'P02')
#2 p01   Ma        4 10A  
#3 p01   Ma        7 10A  
#4 p01   Mi        1 10A  
#5 p01   Mi        4 10A  
#6 p01   Vi        5 10A  
#7 p02   Lu        5 10A    # (cuplat cu 'P01')
#8 p02   Ma        4 10A  
#9 p02   Mi        4 10A 
## … with 875 more rows

Avem aici tipul cel mai obişnuit, de cuplaje (ne abţinem să vizăm în mod explicit, vreo altă categorie): doi profesori intră simultan la o aceeaşi clasă (împărţită în două grupe); recunoaştem un cuplaj prin faptul că apar valori identice pe coloanele zi, ora şi cls.

Reluăm din [1], maniera de evidenţiere a cuplajelor existente în orarul iniţial:

cpl <- lmk %>% split(list(.$zi, .$ora, .$cls))
cpl <- map(seq_along(cpl), function(i) 
           if(nrow(cpl[[i]]) > 1) cpl[[i]]) %>% 
       compact()
cpl <- map_df(seq_along(cpl), function(i) 
              tibble(cup = paste(c(as.character(cpl[[i]]$prof)), 
                                 collapse=""),  # în [1] foloseam "-"
                     cls = cpl[[i]]$cls[1])) %>%
       count(cup, cls)
## A tibble: 20 x 3
#   cup    cls    n
# 1 p01p02 10A    3        #11 p06p33 10F    1
# 2 p01p02 11A    3        #12 p06p33 9A     1
# 3 p01p02 11B    3        #13 p06p33 9B     1
# 4 p01p02 12A    3        #14 p06p33 9C     1
# 5 p01p02 9A     3        #15 p08p11 12E    1
# 6 p06p33 10A    1        #16 p08p25 12E    2
# 7 p06p33 10B    1        #17 p08p47 12E    5
# 8 p06p33 10C    1        #18 p11p44 11E    6
# 9 p06p33 10D    1        #19 p34p07 10E    5
#10 p06p33 10E    1        #20 p34p09 9E     5

De data aceasta am notat profesorii fictivi introduşi pe orele cuplate, prin "PxPy" (în loc de "Px-Py" din [1]); este totdeauna mai bine, să evităm caracterele dinafara celor alfanumerice (de exemplu, '-' este folosit în igraph pentru a indica o muchie a grafului – ori Px-Py nu este o muchie, ci eventual un vârf al grafului profesorilor). Deasemenea, am înlocuit "P" cu "p" – literele mici fiind de preferat, pentru lizibilitate, în identificatori care combină litere şi cifre ("P08P25" versus "p08p25").
Următoarea funcţie permite separarea celor doi profesori dintr-un cuplaj:

split_cuplu <- function(cup)
    strsplit(cup, "(?<=.{3})", perl=TRUE)[[1]]

Şablonul de expresie regulată "(?<=.{3})" (positive lookbehind) operează astfel, asupra şirului indicat de cup: avansează până ce în spate rămân 3 caractere, le produce şi apoi repetă din noua poziţie curentă; de exemplu, split_cuplu("xyzuvwabcd") ne dă vectorul format din "xyz", "uvw", "abc" şi restul "d".

Pentru o linie indicată din cpl, următoarea funcţie produce un tabel tibble care conţine perechile de linii din lmk care au valori respectiv egale în ultimele trei câmpuri, adăugând pe fiecare linie profesorul fictiv asociat fiecărei perechi:

trace_cpl <- function(i) {
    pr <- split_cuplu(as.character(cpl[i, 1]))
    q <- cpl[i, 2]  # clasa pe care cuplează
    ls2 <- lmk %>% filter(cls %in% q & prof %in% pr) %>% 
           split(list(.$zi, .$ora))
    trc <- map_df(seq_along(ls2), function(j) 
                  if(nrow(ls2[[j]]) > 1) ls2[[j]])
    trc %>% mutate(cpl[i, 1])  # asociază profesorul fictiv
}
> print(trace_cpl(16))  # (ilustrare, prin consola interactivă)
    #  prof  zi      ora cls   cup   
    #1 p08   Ma        2 12E   p08p25
    #2 p25   Ma        2 12E   p08p25
    #3 p08   Jo        3 12E   p08p25
    #4 p25   Jo        3 12E   p08p25

Procedând ca în [1], eliminăm orele cuplate din lmk şi adăugăm profesorii fictivi, în fiecare caz pe câte o jumătate dintre orele respective (de exemplu, în cazul ilustrat mai sus, lui "p08p25" îi fixăm nu 4 ore, ci numai două, la clasa 12E):

del <- map_df(1:nrow(cpl), trace_cpl)
TD <- del  # păstrează o copie, vizând structurarea informaţiilor de cuplare
lmk <- anti_join(lmk, del[-5])  # elimină orele cuplate
del$prof <- del$cup
del$cup <- NULL
lmk <- full_join(lmk, del) %>% distinct() %>%   # adaugă profesorii fictivi
       select(prof, cls)  # elimină $zi şi $ora
srt <- sort(table(lmk$prof), decreasing=TRUE)  # reinstituie $prof ca factor
lmk$prof <- factor(lmk$prof, levels=names(srt), ordered=TRUE)
lmk <- lmk %>% arrange(prof)  # 836 ore (profesori + profesori-fictivi)
saveRDS(lmk, file="lmk.RDS")

Acum "lmk.RDS" conţine toate lecţiile prof|cls (în număr de 836, pentru cazul de faţă) care se desfăşoară în cursul unei săptămâni – unde prof are ca valori, pe de o parte, toţi profesorii care au în încadrare ore proprii (intră singuri, nu în vreun cuplaj, la clasele respective) şi pe de altă parte, profesorii fictivi, reprezentând câte doi profesori care trebuie să intre împreună la clasele respective.

Să observăm că nu-i obligatoriu ca ambii profesori reprezentaţi de un profesor fictiv, să aibă şi ore proprii; de exemplu, "p47" din cuplul "p08p47" nu are alte ore decât cele 5 pe care este cuplat la clasa 12E cu "p08" (ceea ce înseamnă că alocarea celor 5 lecţii trebuie să ţină seama numai de alocările făcute anterior lecţiilor lui "p08").

Dacă un profesor are ore proprii la o clasă pe care este şi cuplat cu alţi profesori, atunci alocarea orelor proprii trebuie să ţină seama de alocările existente în momentul respectiv pentru profesorii fictivi asociaţi acestor cuplaje. De exemplu, dacă "p06p33" este deja fixat pe ora a 3-a la o anumită clasă, atunci oricăreia dintre lecţiile proprii (la o clasă sau alta) ale celor doi profesori nu i se va mai putea aloca ora a 3-a a zilei respective.

Să constituim două liste care să indice pentru fiecare profesor – dintre cei care intră în vreun cuplaj, respectiv dintre profesorii fictivi – acei alţi profesori de care depinde alocarea lecţiilor sale:

iCup1 <- intersect(as.character(unique(TD$prof)), lmk$prof)
         # (profesorii care intră într-un cuplaj)
Lx1 <- map(iCup1, function(P) {
    V <- vector()
    cps <- TD %>% filter(prof==P) %>% pull(cup) %>% unique()
    for(cp in cps) {
        xy <- split_cuplu(cp)
        if(xy[1] %in% iCup1 | xy[2] %in% iCup1)
            V <- c(V, cp)
    }
    V
})          
names(Lx1) <- iCup1
# $p01  "p01p02"  # la 'p01' alocarea orelor depinde de cea existentă la 'p01p02'
# $p02  "p01p02"
# $p06  "p06p33"
# $p33  "p06p33"
# $p08  "p08p11" "p08p25" "p08p47"
# $p11  "p08p11" "p11p44"
# $p25  "p08p25"
# $p34  "p34p07" "p34p09"
# $p07  "p34p07"
# $p09  "p34p09"

iCup2 <- as.character(unique(TD$cup))  # profesorii fictivi
Lx2 <- map(iCup2, function(cup) {
    cp <- split_cuplu(cup)
    setdiff(c(cp, union(Lx1[[cp[1]]], Lx1[[cp[2]]])), cup)
})
names(Lx2) <- iCup2
# $p01p02  "p01" "p02"
# $p06p33  "p06" "p33"  # la 'p06p33' alocarea depinde de ce avem la 'p06' şi la 'p33'
# $p08p11  "p08" "p11" "p08p25" "p08p47" "p11p44"
# $p08p25  "p08" "p25" "p08p11" "p08p47"
# $p08p47  "p08" "p47" "p08p11" "p08p25"
# $p11p44  "p11" "p44" "p08p11"
# $p34p07  "p34" "p07" "p34p09"
# $p34p09  "p34" "p09" "p34p07"

Alocarea orelor pentru "p08p11" depinde direct de nu mai puţin decât 4 alte alocări (nu 5 totuşi, fiindcă "P47" nu are ore proprii) – încât este de aşteptat să ajungem mereu la câte o clasă la care nu vom mai avea loc pentru a fixa ora unuia dintre cei 4 profesori implicaţi. Dar încă nu-i de speriat: deocamdată dependenţele evidenţiate vizează întreaga săptămână; să sperăm că în [1], când am repartizat pe zile cele 836 de lecţii – conştientizând doar superficial, aceste dependenţe – nu vom fi făcut greşala de a distribui într-o aceeaşi zi prea multe ore, celor 4 profesori (e clar acum că şi repartizarea pe zile, necesită cele două liste formulate mai sus).

În final, salvăm cele două liste:

save(Lx1, Lx2, file="messing.RDS")

Urmează să rescriem daySchoolSchedule.R, pentru ca folosind "messing.RDS", să etichetăm cu orele 1..7 ale zilei, lecţiile repartizate în [1] pe câte o aceeaşi zi; deasemenea, va trebui rescris, pentru a ţine seama şi de cuplaje, programul anterior de reducere a numărului de ferestre.