Generalized cores

Generalized cores

January 20-22, 2023

First approach - based on multirelational networks. In February extended to General multiway cores.

Node properties

Hadley Wickham: Advanced R / 6 Functions / ... (dot-dot-dot)

pDeg <- function(MN,u,C,way1,way2,...){
  L <- MN$links; IU <- which(L[[way1]]==u) 
  IC <- IU[L[[way2]][IU] %in% C]
  return(length(IC))
}

pSum <- function(MN,u,C,way1,way2,weight=NULL,...){
  L <- MN$links; IU <- which(L[[way1]]==u) 
  W <- L[[weight]][IU[L[[way2]][IU] %in% C]]
  return(sum(W))
}

pMax <- function(MN,u,C,way1,way2,weight=NULL,...){
  L <- MN$links; IU <- which(L[[way1]]==u) 
  W <- L[[weight]][IU[L[[way2]][IU] %in% C]]
  return(max(W))
}

pRel <- function(MN,u,C,way1,way2,way3=NULL,...){
  L <- MN$links; IU <- which(L[[way1]]==u) 
  IC <- IU[L[[way2]][IU] %in% C]
  return(length(union(NULL,L[[way3]][IC])))
}

Generalized cores

GenCoresDec <- function(MN,way1,way2,p=NULL,...){ # way3=, weight=
  n <- nrow(MN$nodes[[1]]); C <- 1:n; core <- P <- rep(NA,n)
  L <- MN$links; H <- fibonacci_heap("numeric")
  for(v in 1:n) P[v] <- p(MN,v,C,way1,way2,...)  
  H <- insert(H,as.numeric(P),1:n); mval <- 0
  while(size(H)>0){
    t <- pop(H); val <- as.numeric(names(t)); t <- t[[1]]
    C <- setdiff(C,t); core[t] <- mval <- max(mval,val)
    IU <- which(L[[way1]]==t) 
    NtC <- IU[L[[way2]][IU] %in% C]
    for(e in NtC){
      v <- L[[way2]][e]; pv <- as.numeric(p(MN,v,C,way1,way2,...))
      hand <- handle(H,value=as.integer(v))[[1]]
      if(pv<hand$key) decrease_key(H,hand$key,pv,hand$handle)
    }
  }
  return(core)
}

Generalized two-mode cores for f1 and f2 at levels t1 and t2

January 23, 2023

> reportCore <- function(MN,way1,way2,f1,f2,cores,short=30,...){
+   n1 <- nrow(MN$nodes[[way1]]); n2 <- nrow(MN$nodes[[way2]])
+   cat("Core report:\nn1 =",n1,"  n2 =",n2,"\n")
+   cat("Core1:",cores$core1,"\nCore2:",cores$core2,"\n")
+   F1 <- sapply(1:n1,function(u) f1(MN,u,cores$core2,way1,way2))
+   F2 <- sapply(1:n2,function(v) f2(MN,v,cores$core1,way2,way1))
+   if(max(n1,n2)<=short) cat("deg1:",F1,"\ndeg2:",F2,"\n\n") else{
+     print(table(F1)); print(table(F2))}
+ }
> Gen2modeCore <- function(MN,way1,way2,f1,f2,t1,t2){
+ remove <- function(MN,Ha,Hb,waya,wayb,Ca,Cb,fb,ta,...){
+   C <- c()
+   while(size(Ha)>0) {
+     top <- peek(Ha); val <- as.numeric(names(top)); u <- top[[1]]
+     if(val >= ta) return(C)
+     top <- pop(Ha); L <- MN$links; Ca <- setdiff(Ca,u); C <- c(C,u)
+     IU <- which(L[[waya]]==u) 
+     NtC <- IU[L[[wayb]][IU] %in% Cb]
+     for(e in NtC){
+       v <- L[[wayb]][e]; pv <- as.numeric(fb(MN,v,Ca,wayb,waya,...))
+       hand <- handle(Hb,value=as.integer(v))
+       if(length(hand)>0){hand <- hand[[1]]
+         if(pv<hand$key) decrease_key(Hb,hand$key,pv,hand$handle)
+       } 
+     } 
+   } 
+   return(C)
+ }
+   n1 <- nrow(MN$nodes[[way1]]); n2 <- nrow(MN$nodes[[way2]])
+   C1 <- 1:n1; C2 <- 1:n2; change <- TRUE
+   F1 <- sapply(1:n1,function(u) f1(MN,u,C2,way1,way2))
+   F2 <- sapply(1:n2,function(v) f2(MN,v,C1,way2,way1))
+   H1 <- fibonacci_heap("numeric"); H2 <- fibonacci_heap("numeric")
+   H1 <- insert(H1,as.numeric(F1),C1); H2 <- insert(H2,as.numeric(F2),C2)
+   while(change){change <- FALSE
+     r <- remove(MN,H1,H2,way1,way2,C1,C2,f2,t1)
+     if(length(r)>0) {C1 <- setdiff(C1,r); change <- TRUE}
+     r <- remove(MN,H2,H1,way2,way1,C2,C1,f1,t2)
+     if(length(r)>0) {C2 <- setdiff(C2,r); change <- TRUE}
+     F1 <- sapply(1:n1,function(u) f1(MN,u,C2,way1,way2))
+     F2 <- sapply(1:n2,function(v) f2(MN,v,C1,way2,way1))
+   }
+   return(list(core1=C1,core2=C2))
+ }
> cores <- Gen2modeCore(TM,"U","V",pDeg,pDeg,3,3)
> reportCore(TM,"U","V",pDeg,pDeg,cores)
Core report:
n1 = 6   n2 = 8 
Core1: 1 2 3 4 
Core2: 1 2 5 7 8 
deg1: 4 5 4 3 1 1 
deg2: 3 3 1 2 3 1 3 4 
> cores <- Gen2modeCore(TM,"U","V",pDeg,pDeg,4,2)
> reportCore(TM,"U","V",pDeg,pDeg,cores)
Core report:
n1 = 6   n2 = 8 
Core1: 1 2 3 4 
Core2: 1 2 4 5 7 8 
deg1: 4 5 5 4 2 2 
deg2: 3 3 1 2 3 1 3 4

Example: marmello77

> MA <- fromJSON("https://raw.githubusercontent.com/bavla/ibm3m/master/data/marmello77.json")
> str(MA)
> table(MA$links$an)
 1  2  3  4  5  6  7  8  9 
 2 14  7 22  1  3 18  1  4 
> table(MA$links$pl)
 1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
 1  2  4  1  5  2  5  2  2  1  3  2  2  1  2  2  2  2  1  1  1  1  3  2  4  1  4  5  2  1  1  2  1  1
> cores <- Gen2modeCore(MA,"an","pl",pDeg,pDeg,3,3)
> reportCore(MA,"an","pl",pDeg,pDeg,cores)
Core report:
n1 = 9   n2 = 34 
Core1: 2 4 6 7 
Core2: 3 5 7 11 25 27 28 
deg1: 2 9 0 7 0 3 8 0 1 
deg2: 0 2 4 0 4 2 3 2 2 1 3 2 2 1 2 2 0 0 1 1 0 1 2 2 4 1 4 5 0 0 1 2 0 1 
> cores <- Gen2modeCore(MA,"an","pl",pDeg,pDeg,7,3)
> reportCore(MA,"an","pl",pDeg,pDeg,cores)
Core report:
n1 = 9   n2 = 34 
Core1: 2 4 7 
Core2: 3 5 7 11 25 27 28 
deg1: 2 9 0 7 0 3 8 0 1 
deg2: 0 2 4 0 4 2 3 2 2 1 3 2 2 1 2 2 0 0 1 1 0 1 2 2 3 1 4 3 0 0 1 2 0 1 
> cores <- Gen2modeCore(MA,"an","pl",pDeg,pDeg,4,4)
> reportCore(MA,"an","pl",pDeg,pDeg,cores)
Core report:
n1 = 9   n2 = 34 
Core1: 2 4 
Core2: 3 5 
deg1: 0 4 0 4 0 0 0 0 1 
deg2: 0 0 4 0 4 0 3 2 2 1 1 0 1 1 2 2 0 0 1 1 0 1 2 1 1 1 2 1 0 0 1 0 0 1

To do

Make the computation of properties more efficient (reordering ways, additional index tables)