File Coverage

blib/lib/SNA/Network/Algorithm/Connectivity.pm
Criterion Covered Total %
statement 30 30 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 36 36 100.0


line stmt bran cond sub pod time code
1             package SNA::Network::Algorithm::Connectivity;
2              
3 14     14   154 use strict;
  14         17  
  14         445  
4 14     14   55 use warnings;
  14         17  
  14         390  
5              
6             require Exporter;
7 14     14   54 use base qw(Exporter);
  14         18  
  14         3826  
8             our @EXPORT = qw(identify_weak_components);
9              
10              
11             =head1 NAME
12              
13             SNA::Network::Algorithm::Connectivity - identify network components
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 $number_of_weak_components = $net->identify_weak_components();
24              
25              
26             =head1 METHODS
27              
28             The following methods are added to L.
29              
30              
31             =head2 identify_weak_components
32              
33             Identifies the weak components in the graph.
34             All componets get an id, starting from 0 on.
35             Stores the component id under the hash entry B for each node object.
36             Returns the number of weak components found in the network.
37              
38             =cut
39              
40             sub identify_weak_components {
41 1     1 1 7 my ($self) = @_;
42            
43 1         3 foreach ($self->nodes) {
44 7         10 undef $_->{weak_component_id};
45             }
46            
47 1         2 my $weak_component_id = 0;
48 1         3 my @remainder = $self->nodes();
49 1         2 do {
50 3         8 _weakly_expand_node($remainder[0], $weak_component_id);
51 3         4 $weak_component_id += 1;
52 3         4 @remainder = grep { !defined $_->{weak_component_id} } @remainder;
  11         17  
53             } while (@remainder > 0);
54            
55 1         3 return $weak_component_id;
56             }
57              
58              
59             sub _weakly_expand_node {
60 3     3   2 my ($node, $weak_component_id) = @_;
61            
62 3         5 $node->{weak_component_id} = $weak_component_id;
63 3         4 my @to_expand = ($node);
64              
65 3         6 while (@to_expand) {
66 7         7 my $next_node = shift @to_expand;
67 7         16 my @unassigned_related_nodes = grep { !defined $_->{weak_component_id} } $next_node->related_nodes();
  14         22  
68 7         9 foreach (@unassigned_related_nodes) {
69 4         5 $_->{weak_component_id} = $weak_component_id;
70             }
71 7         15 push @to_expand, @unassigned_related_nodes;
72             }
73             }
74              
75              
76             =head1 AUTHOR
77              
78             Darko Obradovic, C<< >>
79              
80             =head1 BUGS
81              
82             Please report any bugs or feature requests to C, or through
83             the web interface at L. I will be notified, and then you'll
84             automatically be notified of progress on your bug as I make changes.
85              
86              
87              
88              
89             =head1 SUPPORT
90              
91             You can find documentation for this module with the perldoc command.
92              
93             perldoc SNA::Network
94              
95              
96             You can also look for information at:
97              
98             =over 4
99              
100             =item * RT: CPAN's request tracker
101              
102             L
103              
104             =item * AnnoCPAN: Annotated CPAN documentation
105              
106             L
107              
108             =item * CPAN Ratings
109              
110             L
111              
112             =item * Search CPAN
113              
114             L
115              
116             =back
117              
118              
119             =head1 ACKNOWLEDGEMENTS
120              
121              
122             =head1 COPYRIGHT & LICENSE
123              
124             Copyright 2009 Darko Obradovic, all rights reserved.
125              
126             This program is free software; you can redistribute it and/or modify it
127             under the same terms as Perl itself.
128              
129              
130             =cut
131              
132             1; # End of SNA::Network::Algorithm::Connectivity
133