Plecând de la încadrarea săptămânală a profesorilor (prof | cls | nr_ore), prin "distribute_by_days.R" am repartizat lecţiile respective pe zile (v. [1] - I); în plus, am extras şi am organizat în "messing.RDS", datele privitoare la cuplaje (de exemplu, orele alocate profesorului fictiv "p06p33" trebuie făcute împreună, de către profesorii „reali” p06 şi p33; v. [1] - II).
Apoi, prin mount_hours() din "daySchoolSchedule.R" (v. [1] - IV) am produs orarele zilelor, în "orar_lst5.RDS", dar… fără a ţine seama de cuplaje (astfel, execuţia este rezumată foarte mult): pot exista suprapuneri ascunse de ore, de exemplu pot apărea într-o aceeaşi oră a zilei "p06p33" şi "p06", sau "p34p07" şi "p34p09".
Am lăsat altui program, sarcina de a corecta suprapunerile ascunse apărute; iar un alt program ("vrecast.R" din [1] - IV) va reduce apoi, numărul de ferestre.
Aici reluăm programul "correct.R" din [1], îndreptând una-alta şi ducându-l până în faza în care poate corecta (dar foarte repede) majoritatea suprapunerilor ascunse existente; una-două suprapuneri care mai rămân, pe o zi sau alta, pot fi corectate apoi „manual” (mult mai simplu decât să anticipăm în program, toate excepţiile).
Programul nostru este constituit din vreo 5 funcţii „globale” (da – există şi funcţii „locale”) şi o mică secţiune finală care le angajează efectiv, pentru a corecta suprapunerile ascunse existente pe setul de orare zilnice încărcat.
# correct.R source("stmt_utils.R") # which_cols(), chr2vec(), to_matrix() Z <- readRDS("orar_lst5.RDS") # orarele zilelor, cu suprapuneri ascunse load("messing.RDS") # Lx1, Lx2 (dependenţe între profesorii cuplaţi)
În fişierul de „funcţii utilitare” stmt_utils.R (v. [1]) am adăugat:
to_matrix <- function(X) { # orarul prof|cls|ora al unei zile M <- as.matrix(orarByCls(X)) Cls <- M[, 1] M <- M[, 2:ncol(M)] M[is.na(M)] <- '-' # marchează sfârşitul orelor clasei, sau o fereastră row.names(M) <- Cls M # matricea orară a claselor (pe ziua respectivă) }
prin care setul de date prof | cls | ora al unei zile este transformat în „matrice orară”, având liniile indexate prin clase şi ca valori – profesorii care intră în orele date de rangurile coloanelor, la clasele respective:
> Z[[1]] %>% to_matrix() %>% head(., 3) 1 2 3 4 5 6 7 10A "p01p02" "p36" "p12" "p14" "p13" "p21" "p15" 10B "p32" "p18" "p09" "p22" "p05" "p15" "-" 10C "p38" "p07" "p05" "p25" "p35" "p16" "-"
Dăm şi un exemplu pentru „dependenţele” avute în vedere:
> Lx1[["p08"]] [1] "p08p11" "p08p25" "p08p47" > Lx2[["p08p11"]] [1] "p08" "p11" "p08p25" "p08p47" "p11p44"
În cursul săptămânii, "p08" partajează anumite clase cu "p11", "p25", sau "p47", iar orele astfel cuplate apar în orar la profesorii fictivi "p08p11", "p08p25" şi "p08p47". Dar pentru fiecare profesor care are ore cuplate cu alţi profesori, orele proprii (la care intră singur) trebuie să nu se suprapună cu orele alocate profesorilor fictivi asociaţi cuplajelor respective; apoi, orele alocate unui profesor fictiv trebuie să nu se suprapună nici cu orele alocate fiecăruia dintre cei doi profesori pe care îi cuplează, nici cu orele alocate altor profesori fictivi care acoperă unul dintre aceştia.
Obs. Aceste dependenţe diferă de la o zi la alta, iar în [1] – şi cu mai mult folos, în [3] – am îngustat după ziua curentă, cele două liste Lx1 şi Lx2 (dar nu este necesar).
Următoarea funcţie produce un tabel care conţine indecşii coloanelor orare pe care apare profesorul indicat:
# Localizează profesorul în coloanele matricei orare a claselor locates <- function(Moc, prf) { nrw <- nrow(Moc) # numărul valorilor unei coloane idx <- which(Moc %in% prf) # ce-i mai bine, "%in%" sau "=="? from <- map_int(idx, function(i) ifelse(i %% nrw == 0L, i %/% nrw, i %/% nrw + 1L)) rows <- map_int(idx, function(i) ifelse(i %% nrw == 0L, nrw, i %% nrw)) xto <- map_int(rows, function(rw) sum(Moc[rw, ] != "-")) # rangul ultimei ore a clasei K <- as.data.frame(cbind(from, xto)) K$cls <- rownames(Moc)[rows] K }
De exemplu:
> locates(Lu, "p02") # 'Lu' este matricea orară a zilei "Lu" (Z[[1]]) from xto cls 1 3 6 9A 2 4 5 11D # '11D' are numai 5 ore, în ziua respectivă 3 5 6 11B > locates(Lu, "p01p02") from xto cls 1 1 7 10A 2 2 6 11B 3 3 6 12A
însemnând că "p02" are alocate în ziua respectivă orele 3, 4 şi 5, respectiv la clasele 9A, 11D şi 11B – clase care în acea zi au 6, 5 şi respectiv 6 ore; de observat că ora a 3-a se suprapune cu ora la clasa 12A alocată lui "p01p02" – iar pentru a corecta, va trebui să mutăm "p02" din coloana 3 într-o altă coloană, diferită de 4 şi 5 dar şi de 1 şi 2 (deci rămâne numai coloana 6), sau să mutăm analog, "p01p02".
Obs. Am redat funcţia locates() şi în [1] – dar acolo foloseam which(Moc == prf), iar acum avem which(Moc %in% prf); efectul este acelaşi, dar între cei doi operatori avem totuşi o deosebire importantă: "==" păstrează atributele obiectului pe care se face căutarea, pe când "%in%" returnează totdeauna un vector (unidimensional):
> str(Lu == c("p01", "p32")) logi [1:28, 1:7] FALSE TRUE FALSE FALSE FALSE FALSE ... # matrice logică [28, 7] - attr(*, "dimnames")=List of 2 ..$ : chr [1:28] "10A" "10B" "10C" "10D" ... ..$ : chr [1:7] "1" "2" "3" "4" ... > str(Lu %in% c("p01", "p32")) logi [1:196] FALSE TRUE FALSE FALSE FALSE FALSE ... # vector logic [196]
Dacă un profesor 'prf' face parte dintr-un cuplaj, atunci alocarea orelor sale depinde de alocarea existentă pentru cei din Lx1[[prf]], iar dacă 'prf' este un profesor fictiv, atunci alocarea orelor sale depinde de alocarea celor din Lx2[[prf]]; următoarea funcţie tabelează cumva, coloanele de pe care 'prf' trebuie mutat, pentru a elimina suprapunerile – ascunse, iniţial – cu profesori de care depinde:
# 'prf' trebuie mutat, dacă stă pe o aceeaşi coloană cu cei din Lx1[[prf]] sau Lx2[[prf]] forced_moves <- function(Moc, prf) { loc <- locates(Moc, prf) # coloanele pe care stă 'prf' Area <- which_cols(Moc, union(Lx1[[prf]], Lx2[[prf]])) if(! is.null(Area)) # Area: coloanele celor dependenţi de 'prf' loc <- loc %>% filter(from %in% Area) # cu cine se suprapune 'prf' if(nrow(loc) == 0) return(NULL) # nu există mutări de forţat not_poss <- function(K) # când 'prf' nu poate muta în coloana K prf %in% Moc[, K] || K %in% Area map_df(1:nrow(loc), function(i) { k1 <- loc$from[i] k2 <- loc$xto[i] kols <- map_int((1:k2)[-k1], function(k) ifelse(not_poss(k), 0, k)) kols <- paste(kols[kols > 0], collapse=" ") data.frame(prof = prf, cls = loc$cls[i], from = k1, to = kols) }) }
De exemplu, să explicităm suprapunerile ascunse prin profesorul fictiv "p01p02":
> for(prf in c("p01p02", Lx2[["p01p02"]])) + print(forced_moves(Lu, prf)) prof cls from to 1 p01p02 10A 1 6 7 2 p01p02 11B 2 6 3 p01p02 12A 3 6 prof cls from to 1 p01 12A 1 4 5 6 2 p01 11A 2 4 5 6 prof cls from to 1 p02 9A 3 6
Vedem astfel că "p01p02" se suprapune în orele 1 şi 2 cu "p01" şi în ora a 3-a cu "p02". Câmpul $to indică setul de coloane pe care ar putea fi mutat profesorul, în fiecare caz ("p02" poate fi mutat numai în coloana 6, confirmând deducerea directă anterioară); dar când nu rezultă nici o coloană pe care să poată fi mutat, în $to vom obţine şirul nul, "".
Următoarea funcţie produce (tot ca „tabel”, de fapt obiect de tip data.frame) setul de mutări corectoare posibile, pentru profesorii implicaţi în cuplaje:
# Setul mutărilor corectoare, pentru profesorii implicaţi în cuplaje which_to_force <- function(Moc) { kor <- map_dfr(names(Lx2), function(cup) map_df(Lx2[[cup]], function (P) if(P %in% Moc) forced_moves(Moc, P))) if(is.null(kor) || nrow(kor) == 0) return(NULL) # nu există suprapuneri ascunse kor %>% distinct() }
Obs. Testul "if(P %in% Moc)" a fost necesar fiindcă Lx2 reflectă cuplajele pe întreaga săptămână, iar Moc reprezintă orarul uneia dintre zile. În schimb, "if(is.null(kor) || nrow(kor)==0)" s-ar reduce de fapt la "if(nrow(kor)==0)", dacă ţinem seama că map_dfr() returnează totdeauna un obiect tibble (eventual "tibble [0 × 0]", cu 0 linii); totuşi, am preferat să evităm orice excepţie (posibilă, dacă ne gândim la conversiile tacite obişnuite în R).
De exemplu, pentru ziua "Lu" am avea acest set, de 13 mutări corectoare:
> print(which_to_force(Lu)) prof cls from to 1 p01 12A 1 4 5 6 2 p01 11A 2 4 5 6 3 p02 9A 3 6 4 p06 5G 1 4 5 6 5 p06 11F 2 4 5 6 6 p33 9D 2 3 4 7 p08 9F 2 5 8 p11 9B 1 2 5 9 p08p25 12E 2 5 10 p11p44 11E 1 2 5 11 p34p09 9E 1 2 6 12 p09 11F 1 2 6 13 p34p07 10E 1 3 7
De ce am folosit mai sus distinct()? În unele zile apare şi "p34" şi "p34p07" şi "p34p09" (mai general, un profesor şi mai mulţi profesori fictivi de care depinde acesta); ca urmare (fiindcă pentru câmpul $to s-au avut în vedere toate dependenţele profesorului), pentru "p34" am putea avea în tabelul obţinut mai sus, două (sau poate şi mai multe) linii identice – câte una pentru fiecare profesor fictiv care îl implică.
Următoarea funcţie asigură mutarea unui profesor dintr-o coloană în alta, ocolind situaţiile care ar atrage noi suprapuneri; bineînţeles că această mutare se face după principiul lui Kempe (v. [1], [2]), înlănţuind unele schimburi între cele două coloane:
# Mutare-Kempe a unui profesor de pe o coloană pe alta move_prof <- function(Moc, h1, h2, prof) { K1 <- Moc[, h1] K2 <- Moc[, h2] # prof NU apare în K2 not_pass <- function(P) # când P nu poate trece din K2 în K1 P == "-" || (P %in% names(Lx2)) && (Lx2[[P]] %in% K1) chain <- function(prof) { path <- vector("integer", 0) i <- match(prof, K1, nomatch=0) while(i) { path <- c(path, i) prof <- K2[i] if(not_pass(prof)) { length(path) <- 0 break } i <- match(prof, K1, nomatch=0) } path } path <- chain(prof) if(! length(path)) return(NULL) Moc[path, c(h1, h2)] <- Moc[path, c(h2, h1)] Moc }
Putem imagina în mai multe moduri, rezolvarea prin move_prof() a cazurilor din tabelul mutărilor corectoare. După fiecare mutare – dacă a fost efectuată cu succes – matricea-orar se schimbă şi implicit, am avea un nou set de mutări corectoare, cu mai puţine cazuri decât cel precedent (funcţiile de mai sus asigură că mutarea nu produce noi suprapuneri ascunse); mai departe am putea atunci să reluăm rezolvarea, pentru noua matrice-orar şi noul set de mutări corectoare – încheind eventual când setul curent a devenit vid. Desigur, va trebui să decidem cumva, la fiecare pas, cu care mutare din setul curent să începem; ce facem apoi, dacă mutarea aleasă se dovedeşte a fi imposibilă; etc.
Am ajunge în fond la o formulare de tip „backtracking recursiv” – dar o evităm deocamdată, fiindcă setul de mutări corectoare iniţial are multe cazuri.
Preferăm aici „să lăsăm calculatorului” alegerea unei ordini de parcurgere a setului iniţial de mutări corectoare, precum şi alegerea uneia dintre coloanele indicate în câmpul $to pe fiecare linie a setului; aplicăm move_prof() pe matricea iniţială şi apoi pe matricea rezultată curent, dar numai pentru liniile din setul iniţial de mutări corectoare (în ordinea aleasă aleatoriu a acestor linii); repetăm până când pe matricea rezultată curent găsim nu mai mult de 'left' (de exemplu, 2) suprapuneri ascunse:
# Corectează majoritatea suprapunerilor ascunse de cuplaje correct <- function(Moc, left = 2) { # rămân cel mult 'left' suprapuneri S <- which_to_force(Moc) # setul iniţial de mutări corectoare if(is.null(S)) return(list(Moc, S)) repeat { Moc1 <- Moc # repetă plecând mereu de la matricea initială S <- slice_sample(S, n=nrow(S)) # ordonează aleatoriu liniile setului S <- S %>% filter(to != "") # ignoră liniile cu mutări imposibile for(i in 1:nrow(S)) { for(k in sample(chr2vec(S$to[i]))) { # alege aleatoriu destinaţia k if(! S$prof[i] %in% Moc1[, k]) { M1 <- move_prof(Moc1, S$from[i], k, S$prof[i]) if(! is.null(M1)) { Moc1 <- M1 break # s-a aplicat mutarea din S pe matricea curentă } } } # trece la următoarea linie din S } nrw <- nrow(which_to_force(Moc1)) if(length(nrw) == 0 || nrw <= left) { Moc <- Moc1 break # matricea curentă are cel mult 'left' suprapuneri ascunse } } list(Moc, which_to_force(Moc)) }
Funcţia chr2vec() invocată aici are o utilitate generală şi am înscris-o în fişierul "stmt_utils.R" (încărcat de la bun început, de "correct.R", ca şi de "vrecast.R", etc.):
chr2vec <- function(Txt) unlist(strsplit(Txt, " "))
Următoarea secvenţă finală angajează to_matrix() pentru a transforma orarele zilnice iniţiale în matrice-orar şi aplică acestora correct(), chiar cu 1 pentru parametrul 'left' (în prealabil, executând cu left=2, am constatat că nu este cazul unei zile pe care să avem două mutări imposibile):
prnTime() [1] 08:23:23 W <- map(Z, to_matrix) W1 <- map(seq_along(W), function(i) correct(W[[i]], left=1)) print(W1) prnTime() # [1] 08:24:34 # saveRDS(W1, file="correct.RDS")
La fiecare execuţie a programului, obţinem (în câteva zeci de secunde, sau poate 1 minut şi ceva, pentru orarul considerat aici) câte un set de matrici-orar pe care a rămas de corectat câte cel mult o singură suprapunere ascunsă (dar de regulă, nu un acelaşi set – dat fiind că în correct() avem alegeri aleatorii asupra ordinii efectuării mutărilor corectoare).
În câteva cazuri, ne-a rămas o singură zi (în altele, două zile) pe care avem de corectat „manual” o ultimă suprapunere ascunsă:
> print.table(W1[[1]][[1]]) # matricea-orar curentă a zilei "Lu" 1 2 3 4 5 6 7 10A p01p02 p36 p12 p14 p13 p21 p15 10B p32 p22 p09 p18 p05 p15 - 10C p07 p38 p05 p25 p35 p16 - 10D p31 p12 p16 p09 p21 p19 - 10E p46 p28 p34p07 p39 p03 p27 p04 10F p03 p06p33 p45 p11 p20 p35 - 11A p25 p23 p35 p40 p01 p20 - 11B p28 p01p02 p13 p05 p02 p12 - 11C p30 p31 p28 p17 p18 - - 11D p27 p10 p04 p02 p58 - - 11E p26 p11p44 p10 p03 p09 - - 11F p14 p25 p23 p06 p26 p09 - 12A p36 p30 p01p02 p01 p17 p04 - 12B p22 p24 p30 p16 p29 p17 - 12C p29 p18 p42 p23 p19 p07 - 12D p49 p27 p08 p22 p15 - - 12E p08p47 p15 p19 p21 p08p25 p08p11 - 12F p12 p20 p06 p04 p07 p26 - 5G p45 p46 p17 p56 p04 p06 - 6G p50 p42 p56 p08 p45 p24 - 7G p62 p40 p21 p32 p24 p33 - 8G p61 p14 p20 p13 p46 p56 p05 9A p24 p32 p02 p36 p14 p05 - 9B p16 p03 p31 p10 p11 p22 - 9C p06p33 p37 p11 p07 p10 p03 - 9D p18 p29 p26 p19 p33 p39 - 9E p38 p34p09 p03 p27 p39 p13 - 9F p37 p08 p33 p45 p23 p10 - > print(W1[[1]][[2]]) # setul mutărilor corectoare prof cls from to 1 p02 9A 3 6
Să observăm întâi că mutarea profesorului p02 din coloana 3 în coloana 6 chiar nu este posibilă – aceasta ar necesita următoarele schimbări succesive între cele două coloane: p02 - p05 - p16 - p19 - p08p11 - p11 iar acum move_prof() ar fi refuzat mutarea (fiindcă not_pass() returnează TRUE, găsind pe aceeaşi coloană p08p11 şi p11); bineînţeles că „manual”, putem încerca să continuăm lanţul de schimbări: p11 - p03 - p13 - p12 - p21 - p33 - p10, dar acum şi această încercare ar eşua: clasa 11E pe linia căreia am ajuns, are numai 5 ore (în locul lui p10 ar veni "-", deci 11E ar căpăta o „fereastră” în ora a 3-a).
Ceea ce putem face este să descompunem cumva, mutarea respectivă; să observăm de exemplu, că p05 nu figurează în coloana 1, deci putem încerca mutarea (6, 1, "p05"), care se reduce la schimburile p05 - p24 - p50 şi aduce p24 pe coloana a 6-a, în linia lui 9A; apoi, mutarea (3, 6, "p02") devine posibilă, revenind la un singur interschimb, p02 - p24 (fiindcă p24 nu figura în coloana 3):
> Lu <- W1[[1]][[1]] > Lu <- move_prof(Lu, 6, 1, "p05") > Lu <- move_prof(Lu, 3, 6, "p02") > which_to_force(Lu) NULL # nu mai există suprapuneri ascunse > W1[[1]] <- list(Lu, NULL) # salvăm noua matrice-orar > W2 <- map(seq_along(W1), function(i) W1[[i]][[1]]) # excludem W1[[i]][[2]], care acum sunt toate, NULL > saveRDS(W2, file="correct.RDS")
În final, "correct.RDS" conţine cele 5 matrice-orar corectate (pe care nu mai avem suprapuneri ascunse); mai departe, ar urma să ne ocupăm de reducerea numărului de ferestre, din orarele respective.
Programul "vrecast.R", constituit în [1]-IV pentru a reduce ferestrele, aşteaptă orarul unei zile într-un anumit format – după profesori, nu după clase – iar apoi lucrează pe matricea-orară a profesorilor (nu a claselor, cum avem în "correct.RDS"). Prin urmare, se cuvine să prevedem nişte posibilităţi de conversie între aceste formate.
Adăugăm în "stmt_utils.R" o funcţie care inversează efectul lui to_matrix(), producând tabelul prof | cls | ora din care prin to_matrix() ar proveni matricea-orară a claselor furnizată acum ca argument:
ere_matrix <- function(M) { # M: matrice-orară a claselor as.data.frame(M) %>% mutate(cls = rownames(M)) %>% relocate(cls, .before=1) %>% pivot_longer(., cols = 2:(ncol(M)+1), names_to = "ora", values_to = "prof") %>% filter(prof != '-') # prof|cls|ora }
Iar următoarea funcţie, preluând o matrice-orară a claselor, va produce obiectul data.frame care „include” (ca formă) matricea-orară a profesorilor, corespunzătoare matricei primite:
to_table <- function(M) { # matrice-orară a claselor df <- ere_matrix(M) %>% orarByProf() df[is.na(df)] <- '-' df # tabel reductibil prin as.matrix() la matricea-orară a profesorilor }
Dacă X este una dintre matricele-orar din "correct.RDS", atunci prin X <- to_table(X) şi apoi prin as.matrix(X[, 2:ncol(X)]) vom obţine acea matrice-orar pe care lucrează "vrecast.R" (trebuie doar – prin row.names(X) – să-i mai setăm ca nume de linii, numele profesorilor). Prin urmare, acum putem pasa "correct.RDS" lui "vrecast.R", obţinând în final un set de orare zilnice propriu-zise, fiecare având nu mai mult de 6 sau 7 ferestre (mai puţin de 4% din totalul orelor claselor din acea zi).
vezi Cărţile mele (de programare)