File Coverage

blib/lib/SNA/Network/Generator/ConfigurationModel.pm
Criterion Covered Total %
statement 22 22 100.0
branch 2 2 100.0
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 30 30 100.0


line stmt bran cond sub pod time code
1             package SNA::Network::Generator::ConfigurationModel;
2              
3 14     14   75 use strict;
  14         55  
  14         430  
4 14     14   67 use warnings;
  14         25  
  14         647  
5              
6             require Exporter;
7 14     14   67 use base qw(Exporter);
  14         25  
  14         1307  
8             our @EXPORT = qw(generate_by_configuration_model);
9              
10 14     14   72 use List::Util qw(min shuffle);
  14         39  
  14         4411  
11              
12              
13             =head1 NAME
14              
15             SNA::Network::Generator::ConfigurationModel - Generate random networks according to the configuration model
16              
17              
18             =head1 SYNOPSIS
19              
20             use SNA::Network;
21              
22             my $net = SNA::Network->new();
23             $net->generate_by_configuration_model( $other_network );
24             ...
25              
26              
27             =head1 METHODS
28              
29             The following methods are added to L.
30              
31              
32             =head2 generate_by_configuration_model
33              
34             Generates a network according to the configuration model.
35             This means that the random network will have the same degree sequence
36             as the base network which is passed as a parameter.
37             So for each node from the base network, the random network
38             will have a corresponding node with the same in- and outdegree.
39              
40             Note however that this method is prone to produce a few edges less,
41             that cannot be matched in the end because they would introduce cycles
42             or double edges otherwise.
43             So in practice the random network will be only very close to the base networks degree sequence
44             in most cases.
45              
46             =cut
47              
48             sub generate_by_configuration_model {
49 1     1 1 8 my ($self, $base_network) = @_;
50              
51             # create nodes and stubs
52 1         5 foreach my $base_node ($base_network->nodes) {
53 7         28 my $random_node = $self->create_node_at_index(
54             index => $base_node->index,
55             name => 'random',
56             _missing_inbound_links => $base_node->in_degree,
57             _target_out_degree => $base_node->out_degree,
58             );
59             }
60            
61             # create edges
62 1         5 foreach my $node (shuffle $self->nodes) {
63 49 100       160 my @destinations = grep {
64 7         28 $_->{_missing_inbound_links} > 0 && $_->{index} != $node->{index}
65             } shuffle $self->nodes;
66              
67 7         20 my $last_index = min(@destinations - 1, $node->{_target_out_degree} - 1);
68            
69 7         24 foreach ( @destinations[0 .. $last_index] ) {
70 7         25 $self->create_edge( source_index => $node->{index}, target_index => $_->index );
71 7         21 $_->{_missing_inbound_links} -= 1;
72             }
73             }
74             }
75              
76              
77             =head1 AUTHOR
78              
79             Darko Obradovic, C<< >>
80              
81             =head1 BUGS
82              
83             Please report any bugs or feature requests to C, or through
84             the web interface at L. I will be notified, and then you'll
85             automatically be notified of progress on your bug as I make changes.
86              
87              
88              
89              
90             =head1 SUPPORT
91              
92             You can find documentation for this module with the perldoc command.
93              
94             perldoc SNA::Network
95              
96              
97             You can also look for information at:
98              
99             =over 4
100              
101             =item * RT: CPAN's request tracker
102              
103             L
104              
105             =item * AnnoCPAN: Annotated CPAN documentation
106              
107             L
108              
109             =item * CPAN Ratings
110              
111             L
112              
113             =item * Search CPAN
114              
115             L
116              
117             =back
118              
119              
120             =head1 ACKNOWLEDGEMENTS
121              
122              
123             =head1 COPYRIGHT & LICENSE
124              
125             Copyright 2009 Darko Obradovic, all rights reserved.
126              
127             This program is free software; you can redistribute it and/or modify it
128             under the same terms as Perl itself.
129              
130              
131             =cut
132              
133             1; # End of SNA::Network::Generator::ConfigurationModel
134