Relational cores

January 8, 2023

Generalized cores

> 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)
+ }

> 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

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"                                    

> 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")

Italian students mobility 2008 multiway network relational core of order 10

• https://cran.r-project.org/web/packages/sets/index.html
• https://cran.r-project.org/web/packages/sets/vignettes/sets.pdf