# Stability and Significance Examples

    library(clustAnalytics)

## Scoring functions

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.8004386

Additionally, 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.07638889

## Significance

To 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)
    #> + 110/110 edges from cf9d385 (vertex names):
    #>  [1] Mr Hi  --Actor 2  Mr Hi  --Actor 4  Mr Hi  --Actor 12 Mr Hi  --Actor 13
    #>  [5] Mr Hi  --Actor 14 Mr Hi  --Actor 33 Mr Hi  --John A   Actor 2--Actor 7
    #>  [9] Actor 2--Actor 17 Actor 2--Actor 18 Actor 2--Actor 31 Actor 2--Actor 33
    #> [13] Actor 2--John A   Actor 3--Actor 4  Actor 3--Actor 6  Actor 3--Actor 7
    #> [17] Actor 3--Actor 11 Actor 3--Actor 17 Actor 3--Actor 18 Actor 3--Actor 33
    #> [21] Actor 3--John A   Actor 4--Actor 5  Actor 4--Actor 9  Actor 4--Actor 11
    #> [25] Actor 4--Actor 22 Actor 4--Actor 28 Actor 4--Actor 30 Actor 5--Actor 8
    #> [29] Actor 5--Actor 31 Actor 5--Actor 32 Actor 5--John A   Actor 6--Actor 8
    #> [33] Actor 6--Actor 9  Actor 6--Actor 14 Actor 6--Actor 17 Actor 6--Actor 32
    #> [37] Actor 6--John A   Actor 3--Actor 7  Actor 4--Actor 7  Actor 6--Actor 7
    #> + ... omitted several edges

If 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 11.47058824 10.00000000  17.05882353
    #> internal density      1.29491979  1.31334842  1.32254902   0.76885813
    #> edges inside         50.35294118 64.47058824 51.82352941 104.82352941
    #> av degree             5.05882353  5.29411765  5.05882353   6.14705882
    #> FOMD                  0.26470588  0.29411765  0.26470588   0.41176471
    #> expansion             3.47058824  3.00000000  3.47058824   1.29411765
    #> cut ratio             0.14311885  0.13116472  0.14540629   0.07638889
    #> conductance           0.25696234  0.22721733  0.25484480   0.09518717
    #> norm cut              0.37937069  0.35234595  0.38131607   0.19090909
    #> max ODF               0.43576990  0.42917902  0.51172969   0.38911607
    #> average ODF           0.18336040  0.18617003  0.18493603   0.07498851
    #> flake ODF             0.05882353  0.02941176  0.08823529   0.00000000
    #> density ratio         0.87751142  0.87939735  0.86846364   0.90017702
    #> modularity            0.41978961  0.39045036  0.41116042   0.37146614
    #> graph_order          34.00000000 34.00000000 34.00000000  34.00000000
    #> n_clusters            4.00000000  4.00000000  4.00000000   2.00000000
    #> mean_cluster_size     8.50000000  8.50000000  8.50000000  17.00000000
    #> coverage              0.74458874  0.77922078  0.74458874   0.90476190
    #> global density ratio  0.75864388  0.73664056  0.74273256   0.80043860
    #> VIdist_to_GT          0.90782167  0.73220816  0.87293838   0.00000000

With 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.500000e+01 2.500000e+01 2.500000e+01
    #> internal density     2.550000e-01 2.550000e-01 2.550000e-01
    #> edges inside         7.650000e+01 7.650000e+01 7.650000e+01
    #> av degree            3.060000e+00 3.060000e+00 3.060000e+00
    #> FOMD                 4.400000e-01 4.400000e-01 4.400000e-01
    #> expansion            2.800000e-01 2.800000e-01 2.800000e-01
    #> cut ratio            3.733333e-03 3.733333e-03 3.733333e-03
    #> conductance          4.422547e-02 4.422547e-02 4.422547e-02
    #> norm cut             5.938729e-02 5.938729e-02 5.938729e-02
    #> max ODF              3.333333e-01 3.333333e-01 3.333333e-01
    #> average ODF          4.503175e-02 4.503175e-02 4.503175e-02
    #> flake ODF            0.000000e+00 0.000000e+00 0.000000e+00
    #> density ratio        9.851500e-01 9.851500e-01 9.851500e-01
    #> modularity           6.969775e-01 6.969775e-01 6.969775e-01
    #> graph_order          1.000000e+02 1.000000e+02 1.000000e+02
    #> n_clusters           4.000000e+00 4.000000e+00 4.000000e+00
    #> mean_cluster_size    2.500000e+01 2.500000e+01 2.500000e+01
    #> coverage             9.562500e-01 9.562500e-01 9.562500e-01
    #> global density ratio 9.707190e-01 9.707190e-01 9.707190e-01

And 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)

## Stability

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.2778160  0.2923204 0.2379079
    #> NRMI       0.6484393  0.5856512 0.7029481
    #> Rand       0.8428852  0.7842957 0.8632492
    #> AdRand     0.6249826  0.5503509 0.6777580
    #> n_clusters 5.1313131  5.2626263 5.4343434

And 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.09880444  0.1390480 0.0880508
    #> NRMI       0.87680515  0.8323216 0.8943449
    #> Rand       0.95466993  0.9352637 0.9614101
    #> AdRand     0.87426649  0.8169538 0.8921839
    #> n_clusters 6.21212121  7.1212121 6.5353535

We 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.