momente şi schiţe de informatică şi matematică
anti point—and—click

Corectarea suprapunerilor induse de cuplaje

R | orar şcolar
2021 dec

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)

docerpro | Prev | Next