====== Relational cores ======
January 8, 2023
[[.:gcores|Generalized cores]]
===== Function in R =====
> wdir <- "C:/Users/vlado/DL/data/multi/cores"
> setwd(wdir)
> library(jsonlite)
> source("https://raw.githubusercontent.com/bavla/ibm3m/master/multiway/MWnets.R")
> relCore <- function(MN,way1,way2,way3){
+ U <- MN$links[[way1]]; V <- MN$links[[way2]]; R <- MN$links[[way3]]
+ n <- length(MN$nodes[[way1]]$ID)
+ m <- length(U); act <- rep(TRUE,n); I <- 1:m
+ while(any(act)){
+ C <- vector("list",n)
+ for(i in I){ u <- U[i]; v <- V[i]
+ if(act[u]&&act[v]){ r <- R[i]
+ C[[u]] <- union(C[[u]],r); C[[v]] <- union(C[[v]],r)
+ } else I <- setdiff(I, i)
+ }
+ deg <- sapply(C,length); dmin <- min(deg[act])
+ sel <- which(deg==dmin)
+ core[sel] <- dmin; act[sel] <- FALSE
+ }
+ return(core)
+ }
===== Example: Lazega =====
> MN <- fromJSON("https://raw.githubusercontent.com/bavla/ibm3m/master/data/lazega36.json")
> str(MN)
> core <- relCore(MN,"way1","way2","way3")
> core
[1] 14 23 16 25 22 14 24 16 18 23 14 24 21 24 25 27 24 24 24 24 20 24 25 24 25 25 23 24 24 24
[31] 27 24 23 25 25 26
===== Example: EU airports =====
It turned out that in the process the quantity dmin is not monotonic - it can decrease. This required a correction:
> MN <- fromJSON("https://raw.githubusercontent.com/bavla/ibm3m/master/data/AirEu2013Ext.json")
> str(MN)
> relCore <- function(MN,way1,way2,way3){
+ U <- MN$links[[way1]]; V <- MN$links[[way2]]; R <- MN$links[[way3]]
+ n <- length(MN$nodes[[way1]]$ID); dmin <- -1; s <- 0
+ m <- length(U); act <- rep(TRUE,n); I <- 1:m; core <- rep(NA,n)
+ while(any(act)){
+ C <- vector("list",n)
+ for(i in I){ u <- U[i]; v <- V[i]
+ if(act[u]&&act[v]){ r <- R[i]
+ C[[u]] <- union(C[[u]],r); C[[v]] <- union(C[[v]],r)
+ } else I <- setdiff(I, i)
+ }
+ deg <- sapply(C,length); dmin <- max(dmin,min(deg[act]))
+ sel <- which((deg<=dmin)&act); core[sel] <- dmin; act[sel] <- FALSE
+ s <- s+1; cat(s,dmin,sum(act),length(I),"\n")
+ }
+ return(core)
+ }
> core <- relCore(MN,"airA","airB","line")
1 0 417 7176
2 1 269 7176
3 1 265 6336
4 2 203 6324
5 2 200 5600
6 3 149 5580
7 3 147 4932
8 4 119 4920
9 4 117 4354
10 5 98 4320
11 5 93 3838
12 5 92 3682
13 6 82 3660
14 6 80 3370
15 7 69 3338
16 7 68 3012
17 8 62 2976
18 8 59 2700
19 8 55 2446
20 9 49 2336
21 10 46 2148
22 10 44 1990
23 11 37 1914
24 12 31 1626
25 12 30 1288
26 12 29 1252
27 12 28 1174
28 13 23 1098
29 13 19 826
30 13 10 602
31 13 0 198
> table(core)
core
0 1 2 3 4 5 6 7 8 9 10 11 12 13
33 152 65 53 30 25 12 12 13 6 5 7 9 28
>
> table(core)
core
0 1 2 3 4 5 6 7 8 9 10 11 12 13
33 152 65 53 30 25 12 12 13 6 5 7 9 28
> Ok <- core==13; N <- MN$nodes$airA
> cbind(N$ID[Ok],N$iata[Ok],N$country[Ok],N$long[Ok])
[,1] [,2] [,3] [,4]
[1,] "EDDF" "FRA" "DE" "Frankfurt Airport"
[2,] "LFPG" "CDG" "FR" "Charles de Gaulle Airport (Roissy Airport)"
[3,] "LGAV" "ATH" "GR" "Athens International Airport (Eleftherios Venizelos Airport)"
[4,] "EHAM" "AMS" "NL" "Amsterdam Airport Schiphol"
[5,] "EBBR" "BRU" "BE" "Brussels Airport (Zaventem Airport)"
[6,] "LKPR" "PRG" "CZ" "Vaclav Havel Airport Prague"
[7,] "EKCH" "CPH" "DK" "Copenhagen Airport"
[8,] "ESSA" "ARN" "SE" "Stockholm Arlanda Airport"
[9,] "LIMC" "MXP" "IT" "Milan-Malpensa A"
[10,] "EDDM" "MUC" "DE" "Munich Airport"
[11,] "LEBL" "BCN" "ES" "Barcelona El Prat Airport"
[12,] "LLBG" "TLV" "IL" "Ben Gurion Airport"
[13,] "EPWA" "WAW" "PL" "Warsaw Chopin Airport"
[14,] "LROP" "OTP" "RO" "Henri Coanda International Airport"
[15,] "LEMD" "MAD" "ES" "Adolfo Suarez Madrid-Barajas Airport"
[16,] "LHBP" "BUD" "HU" "Budapest Ferenc Liszt International Airport"
[17,] "LIPZ" "VCE" "IT" "Venice Marco Polo Airport"
[18,] "LOWW" "VIE" "AT" "Vienna International Airport"
[19,] "LSZH" "ZRH" "CH" "Zurich Airport"
[20,] "EDDT" "TXL" "DE" "Berlin Tegel Airport"
[21,] "EGLL" "LHR" "GB" "Heathrow Airport"
[22,] "LIRF" "FCO" "IT" "Leonardo da Vinci-Fiumicino Airport"
[23,] "LEMG" "AGP" "ES" "Malaga Airport"
[24,] "LSGG" "GVA" "CH" "Geneva Airport"
[25,] "LBSF" "SOF" "BG" "Sofia Airport"
[26,] "EDDL" "DUS" "DE" "Dusseldorf Airport"
[27,] "EDDH" "HAM" "DE" "Hamburg Airport"
[28,] "LFMN" "NCE" "FR" "Nice Cote d'Azur Airport"
===== Two-mode relational cores =====
> MN <- fromJSON("C:/Users/vlado/docs/papers/2022/ifcs2022/genova/MWnets/students/students.json")
> str(MN)
> relCore2 <- function(MN,way1,way2,way3){
+ U <- MN$links[[way1]]; V <- MN$links[[way2]]; R <- MN$links[[way3]]
+ n1 <- length(MN$nodes[[way1]]$ID); n2 <- length(MN$nodes[[way2]]$ID)
+ n <- n1+n2; dmin <- -1
+ m <- length(U); act <- rep(TRUE,n); I <- 1:m; core <- rep(NA,n)
+ while(any(act)){
+ C <- vector("list",n)
+ for(i in I){ u <- U[i]; v <- n1+V[i]
+ if(act[u]&&act[v]){ r <- R[i]
+ C[[u]] <- union(C[[u]],r); C[[v]] <- union(C[[v]],r)
+ } else I <- setdiff(I, i)
+ }
+ deg <- sapply(C,length); dmin <- max(dmin,min(deg[act]))
+ sel <- which((deg<=dmin)&act); core[sel] <- dmin; act[sel] <- FALSE
+ }
+ res <- list(); res[[way1]] <- core[1:n1]; res[[way2]] <- core[(n1+1):n]
+ return(res)
+ }
>
> library(magrittr)
> MN %>%
+ slice("year==1") %>%
+ flatten("w",c("prov","univ","prog")) ->
+ S
> core <- relCore2(S,"prov","univ","prog")
> str(core)
List of 2
$ prov: num [1:107] 9 9 10 10 9 9 10 7 10 9 ...
$ univ: num [1:79] 7 2 6 2 7 8 8 3 9 2 ...
> table(core$prov)
5 6 7 8 9 10
1 1 15 14 31 45
> table(core$univ)
0 1 2 3 4 5 6 7 8 9 10
1 5 11 6 1 7 11 12 9 7 9
> S$nodes$prov$ID[core$prov==10]
[1] "AN" "AO" "AR" "AV" "BR" "BT" "BZ" "CB" "CE" "CH" "CR" "CS" "CT" "CZ" "FG" "IM" "KR" "LE" "LO"
[20] "LT" "ME" "MI" "MN" "MS" "MT" "NP" "PA" "PD" "PN" "PZ" "RC" "RG" "RI" "RM" "SA" "SP" "SS" "SV"
[39] "TA" "TN" "TO" "TP" "VE" "VR" "VV"
> S$nodes$prov$province[core$prov==10]
[1] "Ancona" "Aosta" "Arezzo" "Avellino"
[5] "Brindisi" "Barletta-Andria-Trani" "South Tyrol" "Campobasso"
[9] "Caserta" "Chieti" "Cremona" "Cosenza"
[13] "Catania" "Catanzaro" "Foggia" "Imperia"
[17] "Crotone" "Lecce" "Lodi" "Latina"
[21] "Messina" "Milan" "Mantua" "Massa and Carrara"
[25] "Matera" "Naples" "Palermo" "Padua"
[29] "Pordenone" "Potenza" "Reggio Calabria" "Ragusa"
[33] "Rieti" "Rome" "Salerno" "La Spezia"
[37] "Sassari" "Savona" "Taranto" "Trento"
[41] "Turin" "Trapani" "Venice" "Verona"
[45] "Vibo Valentia"
> S$nodes$univ$long[core$univ==10]
[1] "Università del Molise" "Università di Bologna" "Università di Firenze" "Università di Messina"
[5] "Università di Padova" "Università di Parma" "Università di Perugia" "Università di Pisa"
[9] "Università di Torino"
>
> w1 <- (1:107)[core$prov==10]
> w2 <- (1:79)[core$univ==10]
> S10 <- slice(MN,"(prov %in% w1)&(univ %in% w2)")
> str(S10)
> mwnX3D(S10,"prov","univ","prog","w",maxsize=1,file="studentsCore10.x3d")
> extract <- function(MN,ways,clus){
+ N <- MN$nodes; L <- MN$links; info <- MN$info
+ P <- paste(paste(ways,clus,sep="/"),collapse=",")
+ event <- list(op="extract",P=P,date=date())
+ info$trace[[length(info$trace)+1]] <- event
+ for(i in 1:length(ways)){ clu <- eval(str2expression(clus[i]))
+ N[[ways[i]]] <- N[[ways[i]]][clu,]
+ L[[ways[i]]] <- as.integer(factor(L[[ways[i]]],levels=clu))
+ }
+ Sc <- list(format="MWnets",info=info,ways=MN$ways,
+ nodes=N,links=L,data<-MN$data)
+ return(Sc)
+ }
>
> Score <- extract(S10,c("prov","univ"),c("w1","w2"))
> str(Score)
> mwnX3D(Score,"prov","univ","prog","w",maxsize=1,file="SCore10.x3d")
X3D inline example
Italian students mobility 2008 multiway network relational core of order 10
Multiway/Bavla This is a 3D layout. Use the mouse to navigate the space - rotate, zoom in/out, ...
===== To do =====
* https://cran.r-project.org/web/packages/sets/index.html
* https://cran.r-project.org/web/packages/sets/vignettes/sets.pdf