Week 7: Community Detection

Fast and Greedy Community Detection

Create Edgelist

ig.undirected <- as.undirected(ig)
#Run clustering algorithm: fast_greedy
transfer.fg<-cluster_fast_greedy(ig.undirected)
#Inspect clustering object
names(transfer.fg)

transfer.fg

#retrieve list of nodes in communities
igraph::groups(transfer.fg)

Adding Community Membership to Node Info

#Inspect community membership vector
transfer.fg$membership
#Compare to vertex names vector
transfer.fg$names
#Membership function
membership(transfer.fg)
#Check order of vertex names
V(ig)$name

#add community membership as a node attribute
transfer.nodes$transfer.fg<-transfer.fg$membership
#summarize node statistics by community
transfer.nodes%>%
  select(-name)%>% group_by(transfer.fg)%>%
  mutate(n=n())%>%
  summarise_all(mean, na.rm=TRUE)%>%
  as.matrix()%>%
  print(digits=2)

nodes.by.gp<-function(network.nodes, groupvar){
  network.nodes%>%
  select(-name)%>%
  group_by_(groupvar) %>%
  mutate(n=n())%>%
  summarise_all(mean, na.rm=TRUE)%>%
  as.matrix()%>%
  print(digits=2)
}

plot(transfer.fg,ig)

Walktrap Community Detection

#Run clustering algorithm: walktrap
transfer.wt<-walktrap.community(ig)
#Inspect community membership
#igraph::groups(transfer.wt)

#Run & inspect clustering algorithm: 10, 20, 100 steps
igraph::groups(walktrap.community(ig, steps=10))
#Run & inspect clustering algorithm: 10 steps
igraph::groups(walktrap.community(ig, steps=20))

#Run & inspect clustering algorithm: 10 steps
#igraph::groups(walktrap.community(ig, steps=100))

#inspect density of between/within community ties
#print(blockmodel(matrix,transfer.wt$membership)$block.model, digits=2)

#add community membership as a vertex attribute
transfer.nodes$transfer.wt<-transfer.wt$membership
#summarize node statistics by community
nodes.by.gp(transfer.nodes,"transfer.wt")

#plot network with community coloring
plot(transfer.wt,ig)

Compare Community Partitions

#compare community partition modularity scores
modularity(transfer.fg)

[1] 0.3455725

modularity(transfer.wt)

[1] 0.2372717

#collect modularity scores to compare
mods<-c(fastgreedy=modularity(transfer.fg), walktrap=modularity(transfer.wt))
mods

fastgreedy   walktrap 
 0.3455725  0.2372717

compare.algs<-function(alg.a,alg.b,compare.meth=c("vi", "nmi", "split.join", "rand", "adjusted.rand")){
  #create list of community objects and methods
  comm.compare<-expand.grid(alg.a=alg.a, alg.b=alg.b, meth=compare.meth, result=NA, stringsAsFactors = FALSE)
  #compare community partitions using a loop
for(i in 1:nrow(comm.compare)){
  comm1<-get(comm.compare$alg.a[i])
  comm2<-get(comm.compare$alg.b[i])
  method<-comm.compare$meth[i]
  comm.compare$result[i]<-compare(comm1, comm2, method)
}
  return(comm.compare)
}

#compare community partitions
compare.algs(alg.a=c("transfer.fg"),alg.b="transfer.wt")

        alg.a       alg.b          meth       result
1 transfer.fg transfer.wt            vi   3.70408455
2 transfer.fg transfer.wt           nmi   0.44915835
3 transfer.fg transfer.wt    split.join 846.00000000
4 transfer.fg transfer.wt          rand   0.83939469
5 transfer.fg transfer.wt adjusted.rand   0.07531851

Leading Label Propogation

#Run clustering algorithm: leading label
transfer.lab<-label.propagation.community(ig)
#Inspect community membership
igraph::groups(transfer.lab)

#add community membership as a vertex attribute
transfer.nodes$transfer.lab<-transfer.lab$membership
#summarize node statistics by community
nodes.by.gp(transfer.nodes,"transfer.lab")

#plot network with community coloring
plot(transfer.lab,ig)

#compare community partitions
compare.algs(alg.a=c("transfer.fg","transfer.wt"),alg.b="transfer.lab")

         alg.a        alg.b          meth       result
1  transfer.fg transfer.lab            vi   3.30638611
2  transfer.wt transfer.lab            vi   2.14518570
3  transfer.fg transfer.lab           nmi   0.43033391
4  transfer.wt transfer.lab           nmi   0.73286114
5  transfer.fg transfer.lab    split.join 765.00000000
6  transfer.wt transfer.lab    split.join 517.00000000
7  transfer.fg transfer.lab          rand   0.69744893
8  transfer.wt transfer.lab          rand   0.76870150
9  transfer.fg transfer.lab adjusted.rand   0.02651215
10 transfer.wt transfer.lab adjusted.rand   0.15503792

Edge Betweeness Community

#Run clustering algorithm: edge betweenness
transfer.edge<-label.propagation.community(ig)
#Inspect community membership
igraph::groups(transfer.edge)

#add community membership as a vertex attribute
transfer.nodes$transfer.edge<-transfer.edge$membership
#summarize node statistics by community
nodes.by.gp(transfer.nodes,"transfer.edge")

plot(transfer.edge,ig)

#collect modularity scores to compare
mods<-c(mods, edge=modularity(transfer.edge))
mods

fastgreedy   walktrap       edge 
0.34557252 0.23727168 0.02395912

#compare community partitions
compare.algs(alg.a=c("transfer.fg","transfer.wt", "transfer.lab"), alg.b="transfer.edge")

          alg.a         alg.b          meth       result
1   transfer.fg transfer.edge            vi   3.30168802
2   transfer.wt transfer.edge            vi   2.12778654
3  transfer.lab transfer.edge            vi   0.06725868
4   transfer.fg transfer.edge           nmi   0.43057820
5   transfer.wt transfer.edge           nmi   0.73483763
6  transfer.lab transfer.edge           nmi   0.99053246
7   transfer.fg transfer.edge    split.join 763.00000000
8   transfer.wt transfer.edge    split.join 512.00000000
9  transfer.lab transfer.edge    split.join  18.00000000
10  transfer.fg transfer.edge          rand   0.69685491
11  transfer.wt transfer.edge          rand   0.76874679
12 transfer.lab transfer.edge          rand   0.99424897
13  transfer.fg transfer.edge adjusted.rand   0.02721859
14  transfer.wt transfer.edge adjusted.rand   0.15827861
15 transfer.lab transfer.edge adjusted.rand   0.98443077

#Eigenvector Community Detection

#Run clustering algorithm: leading eigenvector
transfer.eigen<-leading.eigenvector.community(ig)
#Inspect community membership
igraph::groups(transfer.eigen)

#inspect density of between/within community ties
#print(blockmodel(matrix,transfer.eigen$membership)$block.model, digits=2)

#add community membership as a vertex attribute
transfer.nodes$transfer.eigen<-transfer.eigen$membership
#summarize node statistics by community
nodes.by.gp(transfer.nodes,"transfer.eigen")

      transfer.eigen degree indegree outdegree transfer.fg
 [1,]              1   16.5     8.50       8.0         3.5
 [2,]              2    1.0     0.50       0.5        11.0
 [3,]              3    1.0     0.50       0.5         2.0
 [4,]              4    1.0     0.50       0.5        28.0
 [5,]              5    1.0     0.50       0.5        26.0
 [6,]              6    1.0     0.50       0.5        18.0
 [7,]              7    1.0     0.50       0.5        22.0
 [8,]              8    1.0     0.50       0.5        12.0
 [9,]              9    1.0     0.50       0.5        13.0
[10,]             10    1.0     0.50       0.5        30.0
[11,]             11    1.0     0.50       0.5        31.0
[12,]             12    1.0     0.50       0.5        25.0
[13,]             13    1.0     0.50       0.5        24.0
[14,]             14    1.0     0.50       0.5        21.0
[15,]             15    1.0     0.50       0.5        20.0
[16,]             16    1.0     0.50       0.5        23.0
[17,]             17    1.0     0.50       0.5        19.0
[18,]             18    1.0     0.50       0.5        15.0
[19,]             19    1.0     0.50       0.5        16.0
[20,]             20    1.0     0.50       0.5        14.0
[21,]             21   21.0    10.53      10.5         5.2
[22,]             22   22.9    11.30      11.6         5.1
[23,]             23   17.4     9.29       8.1         3.5
[24,]             24   11.8     5.62       6.1         2.0
[25,]             25   10.1     5.32       4.8         4.9
[26,]             26   12.3     6.21       6.1         4.4
[27,]             27    8.0     3.50       4.5         7.5
[28,]             28    8.4     4.13       4.3         5.4
[29,]             29    7.5     3.75       3.7         6.5
[30,]             30    6.1     2.67       3.4         4.2
[31,]             31    5.0     0.50       4.5         8.0
[32,]             32    5.0     3.00       2.0         1.0
[33,]             33    8.0     3.92       4.1         5.8
[34,]             34    2.0     1.50       0.5        27.0
[35,]             35    5.2     3.50       1.8         5.2
[36,]             36    3.0     1.25       1.8        32.0
[37,]             37    1.7     0.68       1.0         5.1
[38,]             38    3.0     1.00       2.0         5.0
[39,]             39    5.0     3.00       2.0         8.0
[40,]             40    1.0     0.00       1.0         7.0
      transfer.wt transfer.lab transfer.edge   n
 [1,]          48           44            43  24
 [2,]          78          107           104   2
 [3,]          77          118           116   2
 [4,]          75          128           128   2
 [5,]          74          133           133   2
 [6,]          73          158           159   2
 [7,]          76          163           164   2
 [8,]          72          173           174   2
 [9,]          71          184           185   2
[10,]          69          208           209   2
[11,]          68          209           210   2
[12,]          67          218           219   2
[13,]          70          222           223   2
[14,]          65          234           235   2
[15,]          66          251           251   2
[16,]          63          273           273   2
[17,]          64          290           290   2
[18,]          62          303           303   2
[19,]          60          313           313   2
[20,]          61          317           317   2
[21,]          45           25            26  73
[22,]          39           45            45  40
[23,]          55           29            28  49
[24,]          50           49            50  87
[25,]          95           74            76 110
[26,]          56           50            50  24
[27,]          76           72            72   2
[28,]          71           62            63 168
[29,]          85           96            97  73
[30,]         142           86            85   9
[31,]         163            2             2   2
[32,]           2            1             1   1
[33,]          64           49            48  40
[34,]         195           13            11   2
[35,]         119           26            24   4
[36,]          10            7             6   4
[37,]         185          138           137 114
[38,]          28            1             1   1
[39,]           2            1             1   1
[40,]         197          204           205   1

#plot network with community coloring
plot(transfer.eigen,ig)

#collect modularity scores to compare
mods<-c(mods, eigen=modularity(transfer.eigen))
mods

fastgreedy   walktrap       edge      eigen 
0.34557252 0.23727168 0.02395912 0.25979327

#compare community partitions
compare.algs(alg.a=c("transfer.fg","transfer.wt", "transfer.lab", "transfer.edge"), alg.b="transfer.eigen")

           alg.a          alg.b          meth       result
1    transfer.fg transfer.eigen            vi 3.214680e+00
2    transfer.wt transfer.eigen            vi 3.940865e+00
3   transfer.lab transfer.eigen            vi 3.471662e+00
4  transfer.edge transfer.eigen            vi 3.479263e+00
5    transfer.fg transfer.eigen           nmi 3.336722e-01
6    transfer.wt transfer.eigen           nmi 4.410613e-01
7   transfer.lab transfer.eigen           nmi 4.336873e-01
8  transfer.edge transfer.eigen           nmi 4.319134e-01
9    transfer.fg transfer.eigen    split.join 1.011000e+03
10   transfer.wt transfer.eigen    split.join 9.190000e+02
11  transfer.lab transfer.eigen    split.join 7.770000e+02
12 transfer.edge transfer.eigen    split.join 7.790000e+02
13   transfer.fg transfer.eigen          rand 8.175040e-01
14   transfer.wt transfer.eigen          rand 8.572871e-01
15  transfer.lab transfer.eigen          rand 7.076964e-01
16 transfer.edge transfer.eigen          rand 7.066975e-01
17   transfer.fg transfer.eigen adjusted.rand 1.184390e-01
18   transfer.wt transfer.eigen adjusted.rand 4.629025e-02
19  transfer.lab transfer.eigen adjusted.rand 1.530597e-02
20 transfer.edge transfer.eigen adjusted.rand 1.492080e-02