library(clustAnalytics)To compute the scoring functions of a graph and its clusters, we call scoring_functions. Here we try it for the well known Zachary’s karate club graph, using the faction memberships as clusters. type=global gives us the scores of each cluster, while type=global gives us the weighted mean of the local scores, plus some additional global scores
data(karate, package="igraphdata")
scoring_functions(karate, V(karate)$Faction, type="local")
#> size internal density edges inside av degree FOMD expansion cut ratio
#> 1 16 0.8250000 99 6.187500 0.5000000 1.375000 0.07638889
#> 2 18 0.7189542 110 6.111111 0.3333333 1.222222 0.07638889
#> conductance norm cut max ODF average ODF flake ODF density ratio
#> 1 0.10000000 0.1909091 0.3636364 0.05651941 0 0.9074074
#> 2 0.09090909 0.1909091 0.4117647 0.09140548 0 0.8937500
#> modularity
#> 1 NA
#> 2 NA
scoring_functions(karate, V(karate)$Faction, type="global")
#> size internal density edges inside av degree FOMD expansion
#> [1,] 17.05882 0.7688581 104.8235 6.147059 0.4117647 1.294118
#> cut ratio conductance norm cut max ODF average ODF flake ODF
#> [1,] 0.07638889 0.09518717 0.1909091 0.3891161 0.07498851 0
#> density ratio modularity graph_order n_clusters mean_cluster_size
#> [1,] 0.900177 0.3714661 34 2 17
#> coverage global density ratio
#> [1,] 0.9047619 0.8004386Additionally, each of the scores is available individually as its own function, grouped together in the package as the cluster scoring functions family. They are simply called as follows, with the graph and the membership vector as arguments, and return a vector with the scores for each community:
cut_ratio(karate, V(karate)$Faction)
#> [1] 0.07638889 0.07638889To showcase the randomization process, we apply it to the Zachary’s karate club graph, with the default settings (positive weights with no upper bound, which suits this graph):
data(karate, package="igraphdata")
E(karate)
#> + 78/78 edges from 4b458a1 (vertex names):
#> [1] Mr Hi --Actor 2 Mr Hi --Actor 3 Mr Hi --Actor 4 Mr Hi --Actor 5
#> [5] Mr Hi --Actor 6 Mr Hi --Actor 7 Mr Hi --Actor 8 Mr Hi --Actor 9
#> [9] Mr Hi --Actor 11 Mr Hi --Actor 12 Mr Hi --Actor 13 Mr Hi --Actor 14
#> [13] Mr Hi --Actor 18 Mr Hi --Actor 20 Mr Hi --Actor 22 Mr Hi --Actor 32
#> [17] Actor 2--Actor 3 Actor 2--Actor 4 Actor 2--Actor 8 Actor 2--Actor 14
#> [21] Actor 2--Actor 18 Actor 2--Actor 20 Actor 2--Actor 22 Actor 2--Actor 31
#> [25] Actor 3--Actor 4 Actor 3--Actor 8 Actor 3--Actor 9 Actor 3--Actor 10
#> [29] Actor 3--Actor 14 Actor 3--Actor 28 Actor 3--Actor 29 Actor 3--Actor 33
#> [33] Actor 4--Actor 8 Actor 4--Actor 13 Actor 4--Actor 14 Actor 5--Actor 7
#> [37] Actor 5--Actor 11 Actor 6--Actor 7 Actor 6--Actor 11 Actor 6--Actor 17
#> + ... omitted several edges
rewired_karate <- rewireCpp(karate, weight_sel = "max_weight")
E(rewired_karate)
#> + 127/127 edges from fd7ffd9 (vertex names):
#> [1] Actor 28--John A Actor 7 --Actor 16 Actor 9 --Actor 20 Actor 30--Actor 31
#> [5] Actor 3 --Actor 7 Actor 32--Actor 33 Actor 4 --Actor 25 Actor 20--Actor 24
#> [9] Actor 29--Actor 32 Mr Hi --Actor 13 Actor 10--Actor 16 Actor 9 --Actor 11
#> [13] Actor 2 --Actor 32 Actor 20--Actor 31 Actor 7 --Actor 33 Actor 10--Actor 18
#> [17] Actor 9 --Actor 12 Actor 5 --Actor 31 Actor 7 --Actor 27 Actor 10--Actor 11
#> [21] Actor 3 --Actor 6 Actor 5 --Actor 16 Mr Hi --Actor 7 Actor 6 --Actor 24
#> [25] Actor 9 --Actor 27 Actor 9 --Actor 31 Actor 17--Actor 33 Actor 6 --Actor 28
#> [29] Actor 5 --Actor 14 Actor 2 --Actor 18 Actor 2 --Actor 4 Actor 11--Actor 23
#> [33] Actor 25--Actor 31 Actor 15--Actor 18 Actor 2 --Actor 27 Actor 2 --Actor 28
#> [37] Actor 24--Actor 28 Actor 3 --Actor 14 Actor 25--Actor 28 Actor 32--John A
#> + ... omitted several edgesIf the graph is directed, the rewireCpp function automatically detects it and internally runs the implementation for directed graphs. The following example is a food network (where edges indicate predator-prey relationships) from the igraphdata package:
data(foodwebs, package="igraphdata")
rewired_ChesLower <- rewireCpp(foodwebs$ChesLower, weight_sel = "max_weight")Now we compute the scoring functions for the karate club graph. By default the clustering algorithms are Louvain, label propagation and Walktrap, but the function can take any list of clustering algorithms for igraph graphs.
# this corresponds to the club each member ended up with after the split,
# which we could consider the ground truth clustering for this graph.
significance_table_karate <- evaluate_significance(karate, ground_truth=TRUE,
alg_list=list(Louvain=cluster_louvain,
"label prop"= cluster_label_prop,
walktrap=cluster_walktrap),
gt_clustering=V(karate)$Faction)
significance_table_karate
#> Louvain label prop walktrap ground truth
#> size 9.58823529 13.82352941 10.00000000 17.05882353
#> internal density 1.29491979 1.06591696 1.32254902 0.76885813
#> edges inside 50.35294118 83.35294118 51.82352941 104.82352941
#> av degree 5.05882353 5.82352941 5.05882353 6.14705882
#> FOMD 0.26470588 0.35294118 0.26470588 0.41176471
#> expansion 3.47058824 1.94117647 3.47058824 1.29411765
#> cut ratio 0.14311885 0.09379685 0.14540629 0.07638889
#> conductance 0.25696234 0.14357705 0.25484480 0.09518717
#> norm cut 0.37937069 0.24347335 0.38131607 0.19090909
#> max ODF 0.43576990 0.39078720 0.51172969 0.38911607
#> average ODF 0.18336040 0.11416379 0.18493603 0.07498851
#> flake ODF 0.05882353 0.00000000 0.08823529 0.00000000
#> density ratio 0.87751142 0.90424105 0.86846364 0.90017702
#> modularity 0.41978961 0.39907955 0.41116042 0.37146614
#> graph_order 34.00000000 34.00000000 34.00000000 34.00000000
#> n_clusters 4.00000000 3.00000000 4.00000000 2.00000000
#> mean_cluster_size 8.50000000 11.33333333 8.50000000 17.00000000
#> coverage 0.74458874 0.85714286 0.74458874 0.90476190
#> global density ratio 0.75864388 0.78814383 0.74273256 0.80043860
#> VIdist_to_GT 0.90782167 0.42166505 0.87293838 0.00000000With the function evaluate_significance_r we compute the scoring functions as above, and we compare the results to those of a distribution of randomized graphs.
significance_table_karate_r <- evaluate_significance_r(karate, ground_truth=TRUE,
alg_list=list(Louvain=cluster_louvain,
"label prop"= cluster_label_prop,
walktrap=cluster_walktrap),
gt_clustering=V(karate)$Faction,
weight_sel="max_weight",
n_reps=10)Now we generate a graph from a stochastic block model in which we set very strong clusters (the elements in the diagonal of the matrix are much larger than the rest, so the probability of intra-cluster edges is much higher than that of inter-cluster edges).
pm <- matrix (c(.3, .001, .001, .003,
.001, .2, .005, .002,
.001, .005, .2, .001,
.003, .002, .001, .3), nrow=4, ncol=4)
g_sbm <- sample_sbm(100, pref.matrix=pm, block.sizes=c(25,25,25,25))
E(g_sbm)$weight <- 1
significance_table_sbm <- evaluate_significance(g_sbm)
significance_table_sbm
#> Louvain label prop walktrap
#> size 2.452000e+01 2.224000e+01 2.452000e+01
#> internal density 2.216001e-01 2.555507e-01 2.216001e-01
#> edges inside 6.473000e+01 5.940000e+01 6.473000e+01
#> av degree 2.610000e+00 2.540000e+00 2.610000e+00
#> FOMD 4.400000e-01 4.200000e-01 4.400000e-01
#> expansion 1.200000e-01 2.600000e-01 1.200000e-01
#> cut ratio 1.594737e-03 3.166788e-03 1.594737e-03
#> conductance 2.280026e-02 5.861649e-02 2.280026e-02
#> norm cut 3.057268e-02 6.979617e-02 3.057268e-02
#> max ODF 2.282143e-01 2.590476e-01 2.282143e-01
#> average ODF 2.040280e-02 5.382031e-02 2.040280e-02
#> flake ODF 0.000000e+00 0.000000e+00 0.000000e+00
#> density ratio 9.926388e-01 9.870524e-01 9.926388e-01
#> modularity 7.109021e-01 6.972534e-01 7.109021e-01
#> graph_order 1.000000e+02 1.000000e+02 1.000000e+02
#> n_clusters 5.000000e+00 6.000000e+00 5.000000e+00
#> mean_cluster_size 2.000000e+01 1.666667e+01 2.000000e+01
#> coverage 9.775281e-01 9.513109e-01 9.775281e-01
#> global density ratio 9.856733e-01 9.720400e-01 9.856733e-01And as an example of usage for a complete weighted graphs with weights bounded between 0 and 1, we have a graph built from correlations of currency exchange rate returns, in particular from January 2009 with the 13 most traded currencies. In this case we have to set w_max to 1 to keep the upper bound when rewiring the edges.
data(package="clustAnalytics",g_forex)
significance_table_karate_r <- evaluate_significance_r(karate, ground_truth=TRUE,
gt_clustering=V(karate)$Faction,
weight_sel = "const_var",
n_reps=5, w_max=1)Here we perform a nonparametric bootstrap to the karate club graph and the same selection of algorithms. For each instance, the set of vertices is resampled, the induced graph is obtained by taking the new set of vertices with the induced edges from the original graph, and the clustering algorithms are applied. Then, these results are compared to the induced original clusterings using several metrics: the variation of information (VI), normalized reduced mutual information (NRMI) and both adjusted and regular Rand index (Rand and adRand):
b_karate <- boot_alg_list(g=karate, return_data=FALSE, R=99)
b_karate
#> Louvain label prop walktrap
#> VI 0.2841733 0.3472152 0.2660596
#> NRMI 0.6550091 0.5248897 0.6704250
#> Rand 0.8448658 0.7737806 0.8497092
#> AdRand 0.6217019 0.5107819 0.6414919
#> n_clusters 5.7575758 5.6565657 5.8080808And the same for the stochastic block model graph:
b_sbm <- boot_alg_list(g=g_sbm, return_data=FALSE, R=99)
b_sbm
#> Louvain label prop walktrap
#> VI 0.1268092 0.1920558 0.1263846
#> NRMI 0.8637320 0.7842647 0.8638620
#> Rand 0.9406081 0.9209979 0.9437221
#> AdRand 0.8238000 0.7472534 0.8347384
#> n_clusters 9.5151515 10.9595960 9.3939394We can clearly see that for all metrics, the results are much more stable, which makes sense because we created the sbm graph with very strong clusters.