File Coverage

blib/lib/SNA/Network/Algorithm/Betweenness.pm
Criterion Covered Total %
statement 46 46 100.0
branch 5 6 83.3
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 56 57 98.2


line stmt bran cond sub pod time code
1             package SNA::Network::Algorithm::Betweenness;
2              
3 14     14   58 use strict;
  14         15  
  14         463  
4 14     14   57 use warnings;
  14         20  
  14         428  
5              
6             require Exporter;
7 14     14   57 use base qw(Exporter);
  14         15  
  14         4837  
8             our @EXPORT = qw(calculate_betweenness);
9              
10              
11             =head1 NAME
12              
13             SNA::Network::Algorithm::Betweenness - Calculate betweenneess values for all nodes
14              
15              
16             =head1 SYNOPSIS
17              
18             use SNA::Network;
19              
20             my $net = SNA::Network->new();
21             $net->load_from_pajek_net($filename);
22             ...
23             my $r = $net->calculate_betweenness;
24              
25              
26             =head1 METHODS
27              
28             The following methods are added to L.
29              
30             =head2 calculate_betweenness
31              
32             Calculates exact betweenness centrality values for all nodes.
33             Stores the values under the hash entry B for each node object.
34             Uses the algorithm published by Ulrik Brandes in 2001.
35              
36             =cut
37              
38             sub calculate_betweenness {
39 1     1 1 10 my ($self) = @_;
40              
41 1         6 foreach ($self->nodes) {
42 4         10 $_->{betweenness} = 0;
43             }
44            
45 1         5 foreach my $source ($self->nodes) {
46 4         12 foreach ($self->nodes) {
47 16         25 $_->{_predecessors} = [];
48 16         23 $_->{_sigma} = 0;
49 16         23 $_->{_delta} = 0;
50 16         25 $_->{_distance} = -1;
51             }
52 4         7 $source->{_sigma} = 1;
53 4         7 $source->{_distance} = 0;
54            
55 4         7 my @stack = ();
56 4         7 my @queue = ($source);
57            
58 4         12 while (@queue) {
59 9         12 my $v = shift @queue;
60 9         13 push @stack, $v;
61            
62 9         29 foreach my $succ ($v->outgoing_nodes) {
63 6 100       15 if ($succ->{_distance} < 0) {
64 5         13 push @queue, $succ;
65 5         11 $succ->{_distance} = $v->{_distance} + 1;
66             }
67            
68 6 50       15 if ( $succ->{_distance} == $v->{_distance} + 1 ) {
69 6         10 $succ->{_sigma} += $v->{_sigma};
70 6         7 push @{ $succ->{_predecessors} }, $v;
  6         31  
71             }
72             }
73             }
74            
75 4         8 foreach my $w (reverse @stack) {
76 9         9 foreach my $pre ( @{ $w->{_predecessors} } ) {
  9         19  
77 6         23 $pre->{_delta} += ( $pre->{_sigma} / $w->{_sigma} ) * ( 1 + $w->{_delta} );
78             }
79 9 100       33 $w->{betweenness} += $w->{_delta} if $w != $source;
80             }
81             }
82            
83             # normalise & clean up
84 1         12 my $n = int $self->nodes;
85             # my $factor = 1 / ( ($n - 1) * ($n - 2) );
86 1         4 my $factor = ($n - 1) * ($n - 2);
87 1         5 foreach ($self->nodes) {
88 4         6 delete $_->{_predecessors};
89 4         8 delete $_->{_sigma};
90 4         6 delete $_->{_delta};
91 4         5 delete $_->{_distance};
92 4         11 $_->{betweenness} /= $factor;
93             }
94             }
95              
96              
97             =head1 AUTHOR
98              
99             Darko Obradovic, C<< >>
100              
101             =head1 BUGS
102              
103             Please report any bugs or feature requests to C, or through
104             the web interface at L. I will be notified, and then you'll
105             automatically be notified of progress on your bug as I make changes.
106              
107              
108              
109              
110             =head1 SUPPORT
111              
112             You can find documentation for this module with the perldoc command.
113              
114             perldoc SNA::Network
115              
116              
117             You can also look for information at:
118              
119             =over 4
120              
121             =item * RT: CPAN's request tracker
122              
123             L
124              
125             =item * AnnoCPAN: Annotated CPAN documentation
126              
127             L
128              
129             =item * CPAN Ratings
130              
131             L
132              
133             =item * Search CPAN
134              
135             L
136              
137             =back
138              
139              
140             =head1 ACKNOWLEDGEMENTS
141              
142              
143             =head1 COPYRIGHT & LICENSE
144              
145             Copyright 2009 Darko Obradovic, all rights reserved.
146              
147             This program is free software; you can redistribute it and/or modify it
148             under the same terms as Perl itself.
149              
150              
151             =cut
152              
153             1; # End of SNA::Network::Algorithm::PageRank
154