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

Chestiunea cuplajelor existente în orarul şcolar (VI)

R | orar şcolar
2021 nov

Indecşii unui element al matricei

O matrice este în fond un vector, atributat (eventual prin dim()) cu două „dimensiuni”:

> (al <- LETTERS[1:12])  # un vector, cu primele 12 litere
 [1] "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L"
> dim(al) <- c(3, 4); al  # ca matrice cu 3 linii şi 4 coloane
     [,1] [,2] [,3] [,4]
[1,] "A"  "D"  "G"  "J"  # vectorul e mapat pe coloane succesive
[2,] "B"  "E"  "H"  "K" 
[3,] "C"  "F"  "I"  "L" 
> which(al %in% c("E", "I"))  # indecşii unor elemente (în cadrul vectorului)
[1] 5 9
> al[5]  # al 5-lea element al vectorului subiacent matricei
[1] "E"
> al[c(5, 9)]
[1] "E" "I"

Pentru nişte elemente indicate, which() ne dă indecşii primelor apariţii ale acestora în cadrul vectorului subiacent matricei respective. Dar pentru „matricele orare” (după profesori, respectiv după clase) coloanele joacă un rol important: indică ora 1..7 din zi, alocată lecţiei (prof|cls, respectiv cls|prof); deci ne interesează nu atât indecşii returnaţi de which(), cât indecşii de coloană, ai lecţiilor respective.

Următoarele funcţii – introduse în stmt_utils.R – convertesc indecşii returnaţi de which() (pentru un singur element) în indecşi de coloană şi respectiv, de linie:

which_cols <- function(M, elm) {
    nrw <- nrow(M)  # numărul de valori dintr-o coloană a matricei
    map_int(which(M == elm), function(idx)
            ifelse(idx %% nrw == 0, idx %/% nrw, idx %/% nrw + 1L))
}  # coloanele care conţin cel puţin o dată, elementul indicat
which_rows <- function(M, elm) {
    nrw <- nrow(M)
    rows <- map_int(which(M == elm), function(idx) 
                    ifelse(idx %% nrw == 0, nrw, idx %% nrw))
}  # liniile care conţin cel puţin o dată, elementul indicat

Am mai folosit anterior, acest calcul de indecşi – dar în [1] ne-a scăpat cazul special când elementul este ultimul din coloană…

Desigur, după caz, în loc de a apela aceste funcţii – vom putea folosi direct map_int(), după ce vom fi colectat indecşii prin which().

Stabilirea mutărilor corectoare

Reluăm programul conturat în [1], pentru corectarea eventualelor suprapuneri ascunse, între un profesor fictiv (ca "p01p02") şi profesorii pe care îi cuplează ("p01" şi "p02"), sau între profesori fictivi ("p34p07" şi "p34p09", aflaţi într-o aceeaşi coloană orară):

# correct.R
source("stmt_utils.R")  # select_cupl(), orarByCls(), which_cols(), 
Z <- readRDS("orar_lst5_7.RDS")  # orarele zilelor, cu suprapuneri ascunse
load("messing.RDS")  # Lx1, Lx2 (dependenţe între profesorii cuplaţi)
X <- Z[["Lu"]]  # orarul uneia dintre zile
prof_day <- unique(X$prof)  # profesorii şi profesorii fictivi, pe ziua X
Lx1 <- select_cupl(Lx1, prof_day)  # dependenţele existente în ziua X
Lx2 <- select_cupl(Lx2, prof_day)
nam1 <- names(Lx1)  # profesorii care intră în cupluri ("p01", "p02", etc.)
nam2 <- names(Lx2)  # profesorii fictivi ("p01p02", etc.)
## profesorii cu dependenţe de poziţionare, unul faţă de altul, în orar:
dep1 <- unlist(map(seq_along(Lx1), function(i) c(nam1[i], Lx1[[i]])))
dep2 <- unlist(map(seq_along(Lx2), function(i) c(nam2[i], Lx2[[i]])))
dep <- unique(union(dep1, dep2))
#> dep 
# [1] "p01"    "p01p02" "p02"    "p06"    "p06p33" "p33"    "p08"    "p08p11"
# [9] "p08p25" "p08p47" "p11"    "p11p44" "p25"    "p07"    "p34p07" "p09"   
#[17] "p34p09" 
M <- as.matrix(orarByCls(X))
Cls <- M[, 1]
M <- M[, 2:ncol(M)]
M[is.na(M)] <- '-'
row.names(M) <- Cls  # M este matricea orară a claselor
nrw <- nrow(M)  # numărul de valori dintr-o coloană a matricei

> print.table(M)  # formatat aici prin programul utilitar pr şi comenzi Perl
cls 1      2      3      4    5    6    7      cls  1      2      3    4    5    6      7
10A p01p02 p36    p12    p14  p13  p21  p15    12C  p29    p23    p42  p18  p19  p07    -
10B p32    p18    p09    p22  p05  p15  -      12D  p49    p22    p08  p15  p27  -      -
10C p38    p07    p05    p25  p35  p16  -      12E  p08p47 p08p25 p19  p21  p15  p08p11 -
10D p31    p12    p16    p09  p21  p19  -      12F  p12    p20    p06  p04  p07  p26    -
10E p34p07 p28    p46    p39  p03  p27  p04    5G   p06    p46    p17  p56  p04  p45    -
10F p03    p06p33 p45    p11  p20  p35  -      6G   p50    p42    p56  p08  p45  p24    -
11A p25    p01    p35    p40  p23  p20  -      7G   p62    p24    p21  p32  p40  p33    -
11B p28    p01p02 p13    p05  p02  p12  -      8G   p61    p14    p20  p13  p46  p56    p05
11C p30    p31    p28    p17  p18  -    -      9A   p36    p32    p02  p24  p14  p05    -
11D p27    p10    p04    p02  p58  -    -      9B   p11    p03    p31  p10  p16  p22    -
11E p11p44 p26    p10    p03  p09  -    -      9C   p06p33 p37    p11  p07  p10  p03    -
11F p09    p06    p25    p23  p26  p14  -      9D   p18    p33    p26  p19  p29  p39    -
12A p01    p30    p01p02 p36  p17  p04  -      9E   p34p09 p38    p03  p27  p39  p13    -
12B p22    p29    p30    p16  p24  p17  -      9F   p37    p08    p23  p45  p33  p10    -

Următoarea funcţie produce un obiect data.frame care conţine rangurile coloanelor pe care apare profesorul indicat, clasele respective şi rangul maxim de coloană până la care ar putea fi mutată eventual, fiecare apariţie iniţială:

locates <- function(Moc, prf) {
    idx <- which(Moc == prf)
    from <- map_int(idx, function(i) 
                    ifelse(i %% nrw == 0, i %/% nrw, i %/% nrw + 1L))
    rows <- map_int(idx, function(i) 
                    ifelse(i %% nrw == 0, nrw, i %% nrw))
    xto <- map_int(rows, function(rw) 
                   sum(M[rw, ] != "-"))  # rangul ultimei ore a clasei
    K <- as.data.frame(cbind(from, xto))
    K$cls <- rownames(Moc)[rows]
    K
}
    # > locates(M, "p08")
      from xto cls
    1    2   6  9F
    2    3   5 12D
    3    4   6  6G

În exemplul de aici, "p08" apare iniţial în coloanele 2, 3 şi 4 respectiv la clasele 9F, 12D şi 6G. Dar în coloana 2 apare şi "p08p25" (la clasa 12E), deci "p08" va trebui mutat din coloana 2 – dar nu în coloana 7, fiindcă 9F are numai 6 ore şi nu în coloanele 3 şi 4 (care conţin deja "p08").

Coloana claselor este desigur inutilă, dacă ne gândim să mutăm profesori (în matricea orară a claselor); am prevăzut-o pentru eventualitatea că totuşi, am alege să mutăm clasele (în matricea orară a profesorilor) – profitând de faptul că avem deja funcţia necesară (move_cls(), v. [3]).

Funcţia următoare foloseşte rezultatul din locates(), stabilind în care coloane ar putea fi mutat profesorul (nu poate fi mutat într-o coloană care deja îl conţine, nici în una în care apare vreunul dintre cuplurile în care este angajat):

poss_moves <- function(Moc, prf, notx) {
    loc <- locates(Moc, prf) %>%
           filter(from %in% notx)
    if(nrow(loc) == 0) return(NULL)
    map_df(1:nrow(loc), function(i) {
        D <- data.frame(prof = prf,
                        cls = loc$cls[i], 
                        from = loc$from[i])
        qols <- setdiff(loc$from[i]:loc$xto[i], notx)
        exq <- vector("integer", 0)
        for(q in qols) 
            if(prf %in% Moc[, q] || 
                    any(Lx1[[prf]] %in% Moc[, q]) ||
                    any(Lx2[[prf]] %in% Moc[, q]))
                exq <- c(exq, q)
        qols <- setdiff(qols, exq)
        D$to <- paste(qols, collapse=" ")
        D
    })
}
#    > poss_moves(M, "p08", c(1,2,6))
      prof cls from to
    1  p08  9F    2  5
#    > poss_moves(M, "p01", 1:3)
      prof cls from     to
    1  p01 12A    1  4 5 6
    2  p01 11A    2  4 5 6

Din exemplele redate vedem că "p08" trebuie mutat din coloana 2 în coloana 5 – ceea ce (fiindcă am păstrat şi coloana claselor) ar reveni la move_cls(Mop, 2, 5, "9F"), "Mop" fiind însă matricea orară a profesorilor. În schimb, în cazul lui "p01" avem mai multe mutări (din coloana 1 şi respectiv, din coloana 2) de luat în considerare.

Următoarea funcţie aplică poss_moves() tuturor profesorilor fictivi (stabilind întâi coloanele care îi conţin) şi îmbină rezultatele:

set_corr <- function(Moc) {
    kor <- map_dfr(nam2, function(cup) {
        notx <- which_cols(Moc, cup)
        map_df(Lx2[[cup]], function (P) poss_moves(Moc, P, notx))
    })
    xpr <- map_chr(intersect(kor$prof, nam2), function(cup) 
                   ifelse(all(Lx2[[cup]] %in% kor$prof), cup, " "))
    kor %>% filter(! prof %in% xpr)
}
#    > set_corr(M)
         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     p09 11F    1        2 6
    10 p34p07 10E    1        3 7

Prin ultimele două linii din corpul funcţiei, am exclus de exemplu "p34p09" – fiindcă toţi „supuşii” săi ("p09" şi "p34p07", indicaţi în lista Lx2) figurează deja în lista obţinută.

Avem acum, plaja mutărilor (de profesori, sau de clase) care ar corecta suprapunerile ascunse existente în orarul iniţial; dar schimbarea dintr-o coloană în alta implică diverse alte schimbări între cele două coloane (pentru a evita crearea de noi suprapuneri de lecţii) – conducând la o nouă matrice orară, pentru care vom avea o altă plajă (mai redusă, am vrea) de mutări corectoare…

Dar… este posibilă mutarea?

În mod tacit, am respectat regula pe care ne-o fixasem în [1]: să mutăm profesori (liniile 1..9 din tabelul set_corr(M), redat mai sus) şi nu cupluri (cu excepţia din linia 10); următorul mic raţionament ne arată însă că trebuie să prevedem mai multe excepţii.

Vedem în tabelul de mai sus că "p02" trebuie mutat din coloana 3 (unde se suprapune cu "p01p02"), obligatoriu în coloana 6 (la fel, "p08" trebuie mutat din coloana 2 în coloana 5 şi nu în vreo altă coloană); putem verifica direct (listând profesorii care trebuie interschimbaţi consecutiv între cele două coloane) dacă această mutare este „legală”:

col. 3:  p02  p05  p16  p19      ...  # "p08" apare deja în col. 3
col. 6:  p05  p16  p19  p08p11

Interschimbăm consecutiv, între cele două coloane, "p02" cu "p05", "p05" cu "p16", ş.a.m.d. În final, "p08p11" ar trebui mutat din coloana 6 în coloana 3 – ceea ce încalcă regula amintită mai sus; am avea o „excepţie”, dar în cazul de faţă – neacceptabilă, fiindcă "p08" există deja în coloana 3 (la clasa 12D) şi nu poate fi mutat în coloana 6 (12D are numai 5 ore!).

Rămâne totuşi de văzut, cum vom putea trata (sau evita) asemenea excepţii…

Mutarea unui profesor în altă coloană

Avem de mutat un profesor indicat în câmpul $prof al tabelului returnat de set_corr(), din coloana indicată în $from într-una dintre coloanele indicate în $to; iar poss_moves() (apelată în set_corr()) ne-a asigurat că profesorul respectiv nu apare în niciuna dintre coloanele din $to – astfel că procedura de mutare a profesorului devine mai simplă decât aceea de mutare a clasei, specificată anterior în move_cls().

Modelăm interschimbarea consecutivă între coloane, exemplificată mai sus:

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% nam2 && 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)  # ; print(path)
    if(! length(path)) return(NULL)
    # print(Moc[path, c(h1, h2)])
    Moc[path, c(h1, h2)] <- Moc[path, c(h2, h1)]
    # print(Moc[path, c(h1, h2)])
    Moc
}
## Exemplificare (activând liniile comentate):
>    M1 <- move_prof(M, 1, 4, "p01")
[1] 13 23  # indecşii returnaţi de chain() (liniile pe care se mută între coloane)
    1     4 
12A "p01" "p36"
9A  "p36" "p24"  # (înainte de mutare)
    1     4 
12A "p36" "p01"
9A  "p24" "p36"  # (după mutare)
>    M1 <- move_prof(M, 3, 6, "p02")
integer(0)  # mutare neacceptată (cu rezultat NULL)

Mutarea lui "p02" din coloana 3 în coloana 6 – pe care am ilustrat-o direct mai sus – a fost respinsă, în urma semnalării din not_pass() a faptului că "p08p11" s-ar suprapune în coloana 3 cu "p08". Totuşi, "p02" trebuie îndepărtat din coloana 3 şi rămâne să căutăm schimbările intermediare minimale care ar putea rezolva asemenea cazuri.

Da… în mod interactiv (prin aplicaţia /dayRecast) era mult mai simplu (chiar dacă incomod), de eliminat suprapunerile ascunse.

vezi Cărţile mele (de programare)

docerpro | Prev |