File Coverage

blib/lib/SNA/Network/Algorithm/Cores.pm
Criterion Covered Total %
statement 31 35 88.5
branch 5 6 83.3
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 41 46 89.1


line stmt bran cond sub pod time code
1             package SNA::Network::Algorithm::Cores;
2              
3 14     14   54 use strict;
  14         17  
  14         433  
4 14     14   51 use warnings;
  14         30  
  14         379  
5              
6             require Exporter;
7 14     14   72 use base qw(Exporter);
  14         17  
  14         4265  
8             our @EXPORT = qw(calculate_in_ccs);
9              
10              
11             =head1 NAME
12              
13             SNA::Network::Algorithm::Cores - calculate core collapse sequences (CCS)
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 $k_max = $net->calculate_in_ccs();
24              
25              
26             =head1 METHODS
27              
28             The following methods are added to L.
29              
30              
31             =head2 calculate_in_ccs
32              
33             Calculates the in-core collapse sequence of the graph.
34             All nodes get a maximum core membership k, starting from 0 on.
35             Stores the k value under the hash entry B for each node object.
36             Returns the maximum k in the network.
37              
38             =cut
39              
40             sub calculate_in_ccs {
41 1     1 1 7 my ($self) = @_;
42            
43 1         5 foreach ($self->nodes) {
44 10         12 undef $_->{k_in_core};
45 10         18 $_->{_open_pres} = int $_->incoming_nodes;
46             }
47            
48 1         2 my $k = 0;
49 1         4 my @open = $self->nodes;
50            
51 1         3 do {
52 4         5 $k += 1;
53 4         3 my @recheck = ();
54            
55 4         5 foreach my $node (@open) {
56 28 100       40 if ($node->{_open_pres} < $k) {
57 10         12 $node->{k_in_core} = $k - 1;
58 10         50 foreach ($node->outgoing_nodes) {
59 23         25 $_->{_open_pres} -= 1; # unless $_->{k_in_core};
60             }
61 10         17 push @recheck, $node->outgoing_nodes;
62             #TODO check with smaller id only
63             }
64             }
65              
66             RECHECK:
67 4         10 while (@recheck) {
68 23         22 my $node = shift @recheck;
69 23 100       44 next RECHECK if defined $node->{k_in_core};
70            
71 5 50       13 if ($node->{_open_pres} < $k) {
72 0         0 $node->{k_in_core} = $k - 1;
73 0         0 foreach ($node->outgoing_nodes) {
74 0         0 $_->{_open_pres} -= 1; # unless $_->{k_in_core};
75             }
76 0         0 push @recheck, $node->outgoing_nodes;
77             }
78             }
79            
80 4         5 @open = grep { !defined $_->{k_in_core} } @open;
  28         41  
81            
82             } while (@open);
83            
84 1         3 return $k - 1;
85             }
86              
87             #TODO try counting
88              
89              
90             =head1 AUTHOR
91              
92             Darko Obradovic, C<< >>
93              
94             =head1 BUGS
95              
96             Please report any bugs or feature requests to C, or through
97             the web interface at L. I will be notified, and then you'll
98             automatically be notified of progress on your bug as I make changes.
99              
100              
101              
102              
103             =head1 SUPPORT
104              
105             You can find documentation for this module with the perldoc command.
106              
107             perldoc SNA::Network
108              
109              
110             You can also look for information at:
111              
112             =over 4
113              
114             =item * RT: CPAN's request tracker
115              
116             L
117              
118             =item * AnnoCPAN: Annotated CPAN documentation
119              
120             L
121              
122             =item * CPAN Ratings
123              
124             L
125              
126             =item * Search CPAN
127              
128             L
129              
130             =back
131              
132              
133             =head1 ACKNOWLEDGEMENTS
134              
135              
136             =head1 COPYRIGHT & LICENSE
137              
138             Copyright 2009 Darko Obradovic, all rights reserved.
139              
140             This program is free software; you can redistribute it and/or modify it
141             under the same terms as Perl itself.
142              
143              
144             =cut
145              
146             1; # End of SNA::Network::Algorithm::Cores
147