[[pro:bib:euco:ex]]
 
Trace: • ex
Table of Contents

Bibliographic networks - small example

Creation

> wdir <- "C:/Users/vlado/test/biblio"
> setwd(wdir)
> library(jsonlite)
> BL <- fromJSON("https://raw.githubusercontent.com/bavla/biblio/master/Eu/Data/bibList.json")
> Ci <- matrix(
+ c( 0, 1, 0, 1, 1, 0,
+    0, 0, 1, 0, 1, 1,
+    0, 0, 0, 1, 1, 0,
+    0, 0, 0, 0, 1, 1,
+    0, 0, 0, 0, 0, 1,
+    0, 0, 0, 0, 0, 0 ), byrow=TRUE, nrow=6)
> rownames(Ci) <- colnames(Ci) <- BL$wID
> Ci
   w1 w2 w3 w4 w5 w6
w1  0  1  0  1  1  0
w2  0  0  1  0  1  1
w3  0  0  0  1  1  0
w4  0  0  0  0  1  1
w5  0  0  0  0  0  1
w6  0  0  0  0  0  0
> A <- Reduce(union,sapply(BL$authors,function(x) x$aID))
> A
[1] "AB" "CD" "EF" "GH" "IJ" "KL" "MN" "OP" "RS"
> WA <- matrix(0,nrow=length(BL$wID),ncol=length(A))
> rownames(WA) <- BL$wID; colnames(WA) <- A
> for(w in 1:6) WA[w,which(A %in% BL$authors[[w]]$aID)] <- 1
> WA
   AB CD EF GH IJ KL MN OP RS
w1  1  1  1  0  0  0  0  0  0
w2  1  0  0  1  1  0  0  0  0
w3  1  1  1  0  1  1  0  0  0
w4  0  1  0  1  1  0  1  1  0
w5  1  1  1  0  1  1  0  1  0
w6  0  1  0  0  1  0  1  0  1
> 
> C <- Reduce(union,sapply(BL$authors,function(x) x$c))
> C
[1] "IT" "DE" "SI"
> AC <- matrix(0,nrow=length(A),ncol=length(C))
> rownames(AC) <- A; colnames(AC) <- C
> for(w in 1:6) {L <- BL$authors[[w]]$aID; k <- length(L)
+   for(j in 1:k) AC[L[j],BL$authors[[w]]$c[j]] <- 1 }
> AC
   IT DE SI
AB  1  0  0
CD  0  1  0
EF  1  0  0
GH  0  0  1
IJ  0  0  1
KL  1  0  0
MN  0  1  0
OP  0  0  1
RS  0  1  0 
> saveRDS(list(Ci=Ci,WA=WA,AC=AC),file="ExNets.RDS")
> # Ex <- readRDS("ExNets.RDS")
> source("https://raw.githubusercontent.com/bavla/Rnet/master/R/Pajek.R")
> matrix2net(Ci,Net="ExCi.net")
> bimatrix2net(WA,Net="ExWA.net")
> bimatrix2net(AC,Net="ExAC.net")

Reading

The data/networks are available at GitHub/Bavla 

> wdir <- "C:/Users/vlado/test/biblio"
> setwd(wdir)
> library(jsonlite)
> BL <- fromJSON("https://raw.githubusercontent.com/bavla/biblio/master/Eu/Data/bibList.json")
> urlEx <- "https://github.com/bavla/biblio/raw/master/Eu/Data/ExNets.RDS"
> download.file(url=urlEx,destfile=paste0(wdir,"/ExNets.RDS",sep=""))
> Ex <- readRDS("ExNets.RDS")
> Ci <- Ex$Ci; WA <- Ex$WA; AC <- Ex$AC

Some useful functions

Package bibmat 

normalize <- function(M) t(apply(M,1,function(x) x/max(1,sum(x))))
newman <- function(M) t(apply(M,1,function(x) x/max(1,sum(x)-1)))
D0 <- function(M) {diag(M) <- 0; return(M)}
binary <- function(M) {B <- t(apply(M,1,function(x) as.integer(x!=0)))
  colnames(B) <- colnames(M); return(B)}
wodeg <- function(M) apply(M,1,sum)
wideg <- function(M) apply(M,2,sum)
odeg <- function(M) wodeg(binary(M))
ideg <- function(M) wideg(binary(M))
wdeg <- wodeg
Co <- function(M) t(M)%*%M
Cn <- function(M) Co(normalize(M))
Ct <- function(M) D0(t(normalize(M))%*%newman(M))
through <- function(M,S) t(M)%*%S%*%M
arit <- function(a,b) mean(c(a,b))
amin <- function(a,b) min(c(a,b))
amax <- function(a,b) max(c(a,b))
geom <- function(a,b) sqrt(a*b)
harm <- function(a,b) ifelse(a*b==0,0,2/(1/a+1/b))
jacc <- function(a,b) ifelse(a*b==0,0,1/(1/a+1/b - 1))
symm <- function(A,M) {n <- nrow(M); S <- M
  for(i in 1:(n-1)) for(j in (i+1):n) 
    S[i,j] <- S[j,i] <- A(M[i,j],M[j,i])
  return(S)}

Some tests

> wdir <- "C:/Users/vlado/test/biblio"
> setwd(wdir)
> source("https://raw.githubusercontent.com/bavla/biblio/master/code/bibmat.R")
> urlEx <- "https://github.com/bavla/biblio/raw/master/Eu/Data/ExNets.RDS"
> download.file(url=urlEx,destfile=paste0(wdir,"/ExNets.RDS",sep=""))
> Ex <- readRDS("ExNets.RDS")
> Ci <- Ex$Ci; WA <- Ex$WA; AC <- Ex$AC

> WAn <- normalize(WA)
> Cn <- t(WAn)%*%WAn
> wideg(WAn)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 1.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500 
> wideg(Cn)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 1.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500 
> WAt <- newman(WA)
> Ct <- D0(t(WAn)%*%WAt)
> wideg(Ct)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 1.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500 

> sum(Cn)
[1] 6
> sum(Ct)
[1] 6
> empty <- rep(0,length(A))
> WA1 <- rbind(WA,empty,empty)
> rownames(WA1)[7:8] <- c("w7","w8")
> WA1["w8","CD"] <- 1
> WA1
   AB CD EF GH IJ KL MN OP RS
w1  1  1  1  0  0  0  0  0  0
w2  1  0  0  1  1  0  0  0  0
w3  1  1  1  0  1  1  0  0  0
w4  0  1  0  1  1  0  1  1  0
w5  1  1  1  0  1  1  0  1  0
w6  0  1  0  0  1  0  1  0  1
w7  0  0  0  0  0  0  0  0  0
w8  0  1  0  0  0  0  0  0  0
> WAn1 <- normalize(WA1)
> Cn1 <- t(WAn1)%*%WAn1
> sum(Cn1)
[1] 7
> WAt1 <- newman(WA1)
> Ct1 <- D0(t(WAn1)%*%WAt1)
> sum(Ct1)
[1] 6
> wideg(WAn1)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 2.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500 
> wdeg(Cn1)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 2.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500 
> wdeg(Ct1)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
1.0333 1.1500 0.7000 0.5333 1.1500 0.3667 0.4500 0.3667 0.2500  
> sum(wideg(WAn1))
[1] 7

> Cin <- normalize(Ci)
> CoCin <- t(Cin)%*%Cin
> CoCan <- t(WAn)%*%CoCin%*%WAn
> wdeg_CoCan <- (t(WAn)%*%wideg(Cin))[,1]
> wdeg_CoCan
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
0.4556 0.9694 0.3444 0.2778 1.0806 0.3444 0.6250 0.4444 0.4583 
> wodeg(CoCan)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
0.4556 0.9694 0.3444 0.2778 1.0806 0.3444 0.6250 0.4444 0.4583 
> Can <- Cin%*%WAn
> wideg(Can)
    AB     CD     EF     GH     IJ     KL     MN     OP     RS 
0.4556 0.9694 0.3444 0.2778 1.0806 0.3444 0.6250 0.4444 0.4583 

> biC <- Cin %*% t(Ci)
> biCo <- Ci %*% t(Ci)

> (wicin <- wideg(Cin))
       w1        w2        w3        w4        w5        w6 
0.0000000 0.3333333 0.3333333 0.8333333 1.6666667 1.8333333 

> wideg(biC)
      w1       w2       w3       w4       w5       w6 
2.833333 3.833333 2.500000 3.500000 1.833333 0.000000 
> (Ci %*% wicin)[,1]
      w1       w2       w3       w4       w5       w6 
2.833333 3.833333 2.500000 3.500000 1.833333 0.000000 

> wodeg(biC)
      w1       w2       w3       w4       w5       w6 
2.333333 2.666667 3.000000 3.500000 3.000000 0.000000 
> (Cin %*% ideg(Ci))[,1]
      w1       w2       w3       w4       w5       w6 
2.333333 2.666667 3.000000 3.500000 3.000000 0.000000 

> biConG <- symm(geom,biC)
> (biCa <- through(WAn,biConG))
          AB        CD         EF         GH        IJ         KL         MN         OP RS
AB 0.5915234 0.5093036 0.38408370 0.33265960 0.5141621 0.18150245 0.12521988 0.18507268  0
CD 0.5093036 0.4693287 0.35854188 0.26154849 0.4273296 0.16578111 0.11078678 0.16213478  0
EF 0.3840837 0.3585419 0.28775510 0.16711538 0.2893263 0.12221088 0.07078678 0.09856456  0
GH 0.3326596 0.2615485 0.16711538 0.25997732 0.3628391 0.10286179 0.09443311 0.15007835  0
IJ 0.5141621 0.4273296 0.28932627 0.36283912 0.5334787 0.17063957 0.13800333 0.22142635  0
KL 0.1815025 0.1657811 0.12221088 0.10286179 0.1706396 0.06777778 0.04357023 0.07134800  0
MN 0.1252199 0.1107868 0.07078678 0.09443311 0.1380033 0.04357023 0.04000000 0.06357023  0
OP 0.1850727 0.1621348 0.09856456 0.15007835 0.2214264 0.07134800 0.06357023 0.11491823  0
RS 0.0000000 0.0000000 0.00000000 0.00000000 0.0000000 0.00000000 0.00000000 0.00000000  0
pro/bib/euco/ex.txt · Last modified: 2023/12/01 04:41 by vlado
 
Except where otherwise noted, content on this wiki is licensed under the following license: CC Attribution-Noncommercial-Share Alike 3.0 Unported
Recent changes RSS feed Donate Powered by PHP Valid XHTML 1.0 Valid CSS Driven by DokuWiki