Blockmodeling and Structure Equivalence

WEN, Tzai-Hung (NTU Geography)

library(sna)
library(igraph)

1. Structure Equivalence

setwd("D:/R_Labs")
data<- "sample_adjmatrix.csv"
el<-read.table(data, header=T, row.names=1, sep=",")
m=as.matrix(el)
gplot(m, displaylabels=TRUE)

#?sedist()
sedist(m) 

##      [,1] [,2] [,3] [,4] [,5] [,6] [,7]
## [1,]    0    2    4    2    2    4    4
## [2,]    2    0    6    4    4    6    6
## [3,]    4    6    0    6    6    8    4
## [4,]    2    4    6    0    4    2    6
## [5,]    2    4    6    4    0    6    2
## [6,]    4    6    8    2    6    0    8
## [7,]    4    6    4    6    2    8    0

eq<-equiv.clust(m)
plot(eq)

2. CONCOR algorithm and Blockmodel

[source: CONCOR in R] (http://www.r-bloggers.com/concor-in-r/)

#INSTALL CONCOR
devtools::install_github("aslez/concoR")

## WARNING: Rtools is required to build R packages, but is not currently installed.
## 
## Please download and install Rtools 3.3 from http://cran.r-project.org/bin/windows/Rtools/ and then run find_rtools().
## Downloading github repo aslez/concoR@master
## Installing concoR
## "C:/PROGRA~1/R/R-32~1.1/bin/x64/R" --no-site-file --no-environ --no-save  \
##   --no-restore CMD INSTALL  \
##   "C:/Users/thwen/AppData/Local/Temp/RtmpMbe8Eb/devtools10143d362155/aslez-concoR-d162e5f"  \
##   --library="C:/Users/thwen/Documents/R/win-library/3.2" --install-tests

#LIBRARIES
library(concoR)

#LOAD DATA
data(bank_wiring)
bank_wiring #Liking, Games, Antagonism, Helping

## $Liking
##    I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4
## I1  0  0  0  0  1  0  0  0  0  0  0  0  0  0
## I3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W1  0  0  0  0  1  1  0  0  0  0  0  1  0  0
## W2  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W3  1  0  1  0  0  1  0  0  0  0  0  1  0  0
## W4  0  0  1  0  1  0  0  0  0  0  0  1  0  0
## W5  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W6  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W7  0  0  0  0  0  0  0  0  0  1  1  1  0  0
## W8  0  0  0  0  0  0  0  0  1  0  1  0  0  1
## W9  0  0  0  0  0  0  0  0  1  1  0  0  0  1
## S1  0  0  1  0  1  1  0  0  1  0  0  0  0  0
## S2  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## S4  0  0  0  0  0  0  0  0  0  1  1  0  0  0
## 
## $Games
##    I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4
## I1  0  0  1  1  1  1  0  0  0  0  0  0  0  0
## I3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W1  1  0  0  1  1  1  1  0  0  0  0  1  0  0
## W2  1  0  1  0  1  1  0  0  0  0  0  1  0  0
## W3  1  0  1  1  0  1  1  0  0  0  0  1  0  0
## W4  1  0  1  1  1  0  1  0  0  0  0  1  0  0
## W5  0  0  1  0  1  1  0  0  1  0  0  1  0  0
## W6  0  0  0  0  0  0  0  0  1  1  1  0  0  0
## W7  0  0  0  0  0  0  1  1  0  1  1  0  0  1
## W8  0  0  0  0  0  0  0  1  1  0  1  0  0  1
## W9  0  0  0  0  0  0  0  1  1  1  0  0  0  1
## S1  0  0  1  1  1  1  1  0  0  0  0  0  0  0
## S2  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## S4  0  0  0  0  0  0  0  0  1  1  1  0  0  0
## 
## $Antagonism
##    I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4
## I1  0  1  0  1  0  0  0  0  0  0  0  0  0  0
## I3  1  0  0  0  0  0  1  1  1  1  1  0  0  1
## W1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W2  1  0  0  0  0  0  0  0  1  1  1  0  0  0
## W3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W4  0  0  0  0  0  0  1  0  0  0  0  0  0  0
## W5  0  1  0  0  0  1  0  1  1  1  1  1  1  0
## W6  0  1  0  0  0  0  1  0  1  0  0  0  0  0
## W7  0  1  0  1  0  0  1  1  0  0  0  0  0  0
## W8  0  1  0  1  0  0  1  0  0  0  0  0  0  0
## W9  0  1  0  1  0  0  1  0  0  0  0  0  0  0
## S1  0  0  0  0  0  0  1  0  0  0  0  0  0  0
## S2  0  0  0  0  0  0  1  0  0  0  0  0  0  0
## S4  0  1  0  0  0  0  0  0  0  0  0  0  0  0
## 
## $Helping
##    I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4
## I1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## I3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W1  0  0  0  0  1  0  0  0  0  0  1  1  0  0
## W2  0  0  0  0  1  1  0  0  0  0  0  1  0  0
## W3  0  0  0  1  0  0  0  0  0  0  0  0  0  0
## W4  0  0  1  0  1  0  0  1  0  0  0  0  0  0
## W5  0  0  0  0  1  0  0  0  0  0  0  0  0  0
## W6  0  0  0  0  1  0  0  0  1  1  1  0  0  0
## W7  0  0  0  0  0  0  0  0  0  0  0  0  0  1
## W8  0  0  0  0  0  0  0  1  1  0  1  0  0  0
## W9  0  0  0  0  0  0  0  0  0  0  0  0  0  1
## S1  0  0  0  0  0  0  0  0  1  0  0  0  0  0
## S2  0  0  0  0  0  0  0  1  0  0  0  0  0  0
## S4  0  0  0  0  0  1  0  0  0  1  0  0  0  0
## 
## $Windows
##    I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4
## I1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## I3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W2  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W3  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## W4  0  0  0  0  0  0  1  1  1  0  1  0  0  0
## W5  0  0  0  0  0  1  0  1  0  0  0  1  0  0
## W6  0  0  0  0  0  1  1  0  1  1  1  1  0  1
## W7  0  0  0  0  0  1  0  1  0  1  1  0  0  1
## W8  0  0  0  0  0  0  0  1  1  0  1  1  0  1
## W9  0  0  0  0  0  1  0  1  1  1  0  1  0  0
## S1  0  0  0  0  0  0  1  1  0  1  1  0  0  1
## S2  0  0  0  0  0  0  0  0  0  0  0  0  0  0
## S4  0  0  0  0  0  0  0  1  1  1  0  1  0  0

#CHECK INITIAL CORRELATIONS (TABLE III)
m0 <- cor(do.call(rbind, bank_wiring))
round(m0, 2)

##       I1    I3    W1    W2    W3    W4    W5    W6    W7    W8    W9    S1
## I1  1.00 -0.11  0.41  0.27  0.17  0.27  0.27 -0.07  0.00  0.03  0.02  0.37
## I3 -0.11  1.00 -0.14  0.41 -0.17 -0.07  0.27  0.05  0.00 -0.08 -0.09 -0.08
## W1  0.41 -0.14  1.00  0.30  0.58  0.46  0.07 -0.12 -0.08 -0.23 -0.24  0.34
## W2  0.27  0.41  0.30  1.00  0.18  0.17  0.46 -0.12 -0.26 -0.23 -0.24  0.05
## W3  0.17 -0.17  0.58  0.18  1.00  0.38 -0.04 -0.20 -0.10 -0.21 -0.15  0.35
## W4  0.27 -0.07  0.46  0.17  0.38  1.00  0.03  0.03  0.03  0.09 -0.09  0.56
## W5  0.27  0.27  0.07  0.46 -0.04  0.03  1.00  0.11 -0.04  0.01  0.07  0.01
## W6 -0.07  0.05 -0.12 -0.12 -0.20  0.03  0.11  1.00  0.33  0.33  0.38  0.09
## W7  0.00  0.00 -0.08 -0.26 -0.10  0.03 -0.04  0.33  1.00  0.45  0.50  0.08
## W8  0.03 -0.08 -0.23 -0.23 -0.21  0.09  0.01  0.33  0.45  1.00  0.58  0.07
## W9  0.02 -0.09 -0.24 -0.24 -0.15 -0.09  0.07  0.38  0.50  0.58  1.00  0.05
## S1  0.37 -0.08  0.34  0.05  0.35  0.56  0.01  0.09  0.08  0.07  0.05  1.00
## S2 -0.04  0.36 -0.05 -0.05 -0.06  0.22 -0.07  0.22  0.19  0.21  0.20  0.21
## S4 -0.03 -0.15 -0.19 -0.19 -0.24 -0.07  0.11  0.38  0.30  0.36  0.43 -0.08
##       S2    S4
## I1 -0.04 -0.03
## I3  0.36 -0.15
## W1 -0.05 -0.19
## W2 -0.05 -0.19
## W3 -0.06 -0.24
## W4  0.22 -0.07
## W5 -0.07  0.11
## W6  0.22  0.38
## W7  0.19  0.30
## W8  0.21  0.36
## W9  0.20  0.43
## S1  0.21 -0.08
## S2  1.00 -0.05
## S4 -0.05  1.00

#IDENTIFY BLOCKS USING A 4-BLOCK MODEL (TABLE IV)
blks <- concor_hca(bank_wiring, p = 2)
blks

##    block vertex
## 1      1     I1
## 6      2     I3
## 2      1     W1
## 7      2     W2
## 3      1     W3
## 4      1     W4
## 8      2     W5
## 9      3     W6
## 11     4     W7
## 12     4     W8
## 13     4     W9
## 5      1     S1
## 10     3     S2
## 14     4     S4

#CHECK FIT USING SNA (TABLE V)
#code below fails unless glabels are specified
blk_mod <- blockmodel(bank_wiring, blks$block, 
                      glabels = names(bank_wiring),
                      plabels = rownames(bank_wiring[[1]]))
blk_mod

## 
## Network Blockmodel:
## 
## Block membership:
## 
## I1 I3 W1 W2 W3 W4 W5 W6 W7 W8 W9 S1 S2 S4 
##  1  2  1  2  1  1  2  3  4  4  4  1  3  4 
## 
## Reduced form blockmodel:
## 
##   Liking 
##         Block 1 Block 2 Block 3   Block 4
## Block 1    0.70       0       0 0.0500000
## Block 2    0.00       0       0 0.0000000
## Block 3    0.00       0       0 0.0000000
## Block 4    0.05       0       0 0.8333333
## 
##   Games 
##         Block 1    Block 2 Block 3    Block 4
## Block 1     0.9 0.60000000   0.000 0.00000000
## Block 2     0.6 0.00000000   0.000 0.08333333
## Block 3     0.0 0.00000000   0.000 0.37500000
## Block 4     0.0 0.08333333   0.375 1.00000000
## 
##   Antagonism 
##           Block 1   Block 2 Block 3   Block 4
## Block 1 0.0000000 0.2666667   0.000 0.0000000
## Block 2 0.2666667 0.3333333   0.500 0.8333333
## Block 3 0.0000000 0.5000000   0.000 0.1250000
## Block 4 0.0000000 0.8333333   0.125 0.0000000
## 
##   Helping 
##           Block 1    Block 2 Block 3   Block 4
## Block 1 0.2000000 0.06666667   0.100 0.1000000
## Block 2 0.2666667 0.00000000   0.000 0.0000000
## Block 3 0.1000000 0.00000000   0.500 0.3750000
## Block 4 0.0500000 0.00000000   0.125 0.4166667
## 
##   Windows 
##           Block 1   Block 2   Block 3   Block 4
## Block 1 0.0000000 0.1333333 0.2000000 0.2500000
## Block 2 0.1333333 0.0000000 0.1666667 0.0000000
## Block 3 0.2000000 0.1666667 0.0000000 0.5000000
## Block 4 0.2500000 0.0000000 0.5000000 0.8333333

plot(blk_mod)

2.1 Blockmodel: Application

data(studentnets.M182, package = "NetData")

# graph object
m182_full_nonzero_edges <- subset(m182_full_data_frame, (friend_tie > 0 | social_tie > 0 | task_tie > 0))
head(m182_full_nonzero_edges)

##    ego alter friend_tie social_tie task_tie
## 5    1     5          0       1.20     0.30
## 8    1     8          0       0.15     0.00
## 9    1     9          0       2.85     0.30
## 10   1    10          0       6.45     0.30
## 11   1    11          0       0.30     0.00
## 12   1    12          0       1.95     0.15

m182_full <- graph.data.frame(m182_full_nonzero_edges) 
summary(m182_full)

## IGRAPH DN-- 16 144 -- 
## + attr: name (v/c), friend_tie (e/n), social_tie (e/n), task_tie
## | (e/n)

plot(m182_full)

# Create sub-graphs based on edge attributes
m182_friend <- delete.edges(m182_full, E(m182_full)[get.edge.attribute(m182_full,name = "friend_tie")==0])
# Look at the plots for each sub-graph
friend_layout <- layout.fruchterman.reingold(m182_friend)
plot(m182_friend, layout=friend_layout, edge.arrow.size=.5)

# set the network to undirected and remove isolated vertices.
m182_friend_und <- as.undirected(m182_friend, mode='collapse')
m182_friend_no_iso <- delete.vertices(m182_friend_und, V(m182_friend_und)[degree(m182_friend_und)==0])
summary(m182_friend_no_iso)

## IGRAPH UN-- 14 42 -- 
## + attr: name (v/c)

# COMMUNITY DETECTION: EDGE BETWEENNESS METHOD, Newman and Girvan (2004)
friend_comm_eb <- edge.betweenness.community(m182_friend_no_iso)
plot(as.dendrogram(friend_comm_eb))

#Blockmodel
MM <-membership(friend_comm_eb)
communities_full <- vector()
communities_full <- append(communities_full, MM[1:3])
communities_full <- append(communities_full, 4)
communities_full <- append(communities_full, MM[4:14])
communities_full <- append(communities_full, 5)
communities_full

##  1  2  3     5  6  7  8  9 10 11 12 13 14 15    
##  1  2  3  4  3  3  2  2  1  1  3  1  2  2  1  5

m182_friend_nonzero_edges <- subset(m182_full_data_frame, (friend_tie > 0))
m182_friend_nonzero_edges <- m182_friend_nonzero_edges[,1:3]
m182_friend_sna=as.matrix(m182_friend_nonzero_edges)
attr(m182_friend_sna,"n")<-16 # set 16 nodes in a network
gplot(m182_friend_sna,displaylabels=TRUE)

which(sna::degree(m182_friend_sna)==0)

## [1]  4 16

friend_blockmodel <- blockmodel(m182_friend_sna, communities_full)
friend_blockmodel 

## 
## Network Blockmodel:
## 
## Block membership:
## 
##  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 
##  1  2  3  4  3  3  2  2  1  1  3  1  2  2  1  5 
## 
## Reduced form blockmodel:
## 
##   1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 
##         Block 1 Block 2  Block 3 Block 4 Block 5
## Block 1    0.90    0.04 0.050000       0       0
## Block 2    0.12    1.00 0.100000       0       0
## Block 3    0.40    0.15 1.166667       0       0
## Block 4    0.00    0.00 0.000000     NaN       0
## Block 5    0.00    0.00 0.000000       0     NaN

plot(friend_blockmodel)