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)
#> + 130/130 edges from d2f0a88 (vertex names):
#> [1] Actor 6 --Actor 26 Actor 11--Actor 32 Actor 16--John A Actor 2 --Actor 3
#> [5] Actor 4 --Actor 25 Mr Hi --Actor 12 Mr Hi --Actor 13 Actor 4 --Actor 22
#> [9] Actor 11--Actor 23 Actor 2 --Actor 8 Actor 16--Actor 17 Actor 2 --Actor 4
#> [13] Actor 14--Actor 24 Actor 25--Actor 32 Actor 6 --Actor 30 Mr Hi --Actor 14
#> [17] Actor 4 --Actor 27 Actor 2 --Actor 15 Actor 5 --Actor 7 Mr Hi --Actor 18
#> [21] Actor 5 --Actor 26 Actor 7 --Actor 33 Actor 8 --Actor 14 Actor 3 --Actor 9
#> [25] Actor 3 --Actor 10 Actor 17--Actor 32 Actor 2 --Actor 12 Actor 6 --Actor 12
#> [29] Actor 22--Actor 27 Actor 24--Actor 28 Actor 3 --Actor 14 Actor 7 --Actor 31
#> [33] Actor 14--Actor 30 Actor 18--Actor 20 Actor 26--Actor 33 Actor 29--John A
#> [37] Actor 29--Actor 32 Actor 5 --Actor 24 Actor 7 --John A Actor 6 --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,
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
#> clustering coef 0.54148426 0.53726394 0.61381521 0.53406848
#> 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,
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.502000e+01 2.108000e+01 2.500000e+01
#> internal density 2.497362e-01 3.189286e-01 2.508333e-01
#> edges inside 7.464000e+01 6.472000e+01 7.525000e+01
#> av degree 2.990000e+00 2.850000e+00 3.010000e+00
#> FOMD 3.900000e-01 3.500000e-01 3.900000e-01
#> expansion 2.000000e-01 4.800000e-01 1.600000e-01
#> cut ratio 2.661735e-03 5.517894e-03 2.133333e-03
#> conductance 3.488414e-02 9.201318e-02 2.764173e-02
#> norm cut 4.550347e-02 1.042899e-01 3.623560e-02
#> max ODF 3.384921e-01 2.683175e-01 2.093254e-01
#> average ODF 3.108730e-02 7.656349e-02 2.340873e-02
#> flake ODF 1.000000e-02 2.000000e-02 0.000000e+00
#> density ratio 9.882044e-01 9.850953e-01 9.907713e-01
#> modularity 7.135713e-01 6.918445e-01 7.194363e-01
#> clustering coef 2.487578e-01 2.742617e-01 2.466604e-01
#> graph_order 1.000000e+02 1.000000e+02 1.000000e+02
#> n_clusters 4.000000e+00 6.000000e+00 4.000000e+00
#> mean_cluster_size 2.500000e+01 1.666667e+01 2.500000e+01
#> coverage 9.676375e-01 9.223301e-01 9.741100e-01
#> global density ratio 9.785718e-01 9.571478e-01 9.829900e-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,
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.2839103 0.3014715 0.2658768
#> NRMI 0.5362252 0.5278200 0.5813233
#> Rand 0.8457480 0.7877528 0.8519419
#> AdRand 0.6192358 0.5508384 0.6476735
#> n_clusters 5.6565657 4.9292929 5.8484848And 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.09690785 0.1338026 0.07554367
#> NRMI 0.87706041 0.8419264 0.90869694
#> Rand 0.95500663 0.9357270 0.96607081
#> AdRand 0.87220908 0.8123504 0.90400715
#> n_clusters 6.63636364 7.9494949 6.70707071We 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.