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().
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…
Î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…
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)