File Coverage

blib/lib/SNA/Network/Generator/MCMC.pm
Criterion Covered Total %
statement 28 28 100.0
branch 2 2 100.0
condition 7 9 77.7
subroutine 8 8 100.0
pod 1 1 100.0
total 46 48 95.8


line stmt bran cond sub pod time code
1             package SNA::Network::Generator::MCMC;
2              
3 14     14   58 use strict;
  14         20  
  14         444  
4 14     14   57 use warnings;
  14         15  
  14         374  
5              
6             require Exporter;
7 14     14   50 use base 'Exporter';
  14         14  
  14         1057  
8             our @EXPORT = qw(shuffle);
9              
10 14     14   73 use List::MoreUtils qw(uniq none);
  14         18  
  14         4113  
11              
12              
13             =head1 NAME
14              
15             SNA::Network::Generator::MCMC - Generate random networks by a series of edge swaps according to the Markov Chain Monte Carlo principle
16              
17              
18             =head1 SYNOPSIS
19              
20             use SNA::Network;
21              
22             my $net = SNA::Network->new_from_pajek_net($filename);
23             $net->shuffle;
24             ...
25             for (1.100) {
26             say $net->shuffle->identify_weakly_connected_components;
27             }
28              
29              
30             =head1 METHODS
31              
32             The following methods are added to L.
33              
34              
35             =head2 shuffle
36              
37             Generates a random networks by a series of edge swaps on an existing network according to the Markov Chain Monte Carlo principle. This means that the initial network will be changed and have a totally new, random edge structure.
38              
39             This method will exactly preserve all in- and outdegrees, and is guaranteed to sample uniformly at random from all possible simple graph configurations.
40              
41             You may optionally pass the number of steps to perform. By default, the currently best known number is used, namely the number of edges in the network multiplied by its logarithm.
42              
43             Returns the network reference again, in order to enable method chaining.
44              
45             =cut
46              
47             sub shuffle {
48 1     1 1 11 my ($self, $steps) = @_;
49            
50 1   33     9 $steps ||= int (int $self->edges * log int $self->edges);
51              
52 1         3 for (1 .. $steps) {
53 10538         13442 _swap_random_edges($self);
54             }
55            
56 1         8 return $self;
57             }
58              
59              
60             sub _swap_random_edges {
61 10538     10538   8644 my ($self) = @_;
62              
63 10538         18598 my $index_one = int rand int $self->edges;
64 10538         16499 my $index_two = int rand int $self->edges;
65              
66 10538         12038 my $edge_one = $self->{edges}->[$index_one];
67 10538         10185 my $edge_two = $self->{edges}->[$index_two];
68            
69 10538 100 100     83593 if (
      100        
70             uniq($edge_one->source, $edge_one->target, $edge_two->source, $edge_two->target) == 4
71 192353     192353   215175 and none { $_ == $edge_two->target } $edge_one->source->outgoing_nodes
72 162146     162146   165569 and none { $_ == $edge_one->target } $edge_two->source->outgoing_nodes
73             ) {
74             # swap target nodes
75 6952         7158 my $edge_one_target = $edge_one->target;
76 6952         7548 $edge_one->{target} = $edge_two->target;
77 6952         33622 $edge_two->{target} = $edge_one_target;
78             }
79             }
80              
81              
82             =head1 AUTHOR
83              
84             Darko Obradovic, C<< >>
85              
86             =head1 BUGS
87              
88             Please report any bugs or feature requests to C, or through
89             the web interface at L. I will be notified, and then you'll
90             automatically be notified of progress on your bug as I make changes.
91              
92              
93              
94              
95             =head1 SUPPORT
96              
97             You can find documentation for this module with the perldoc command.
98              
99             perldoc SNA::Network
100              
101              
102             You can also look for information at:
103              
104             =over 4
105              
106             =item * RT: CPAN's request tracker
107              
108             L
109              
110             =item * AnnoCPAN: Annotated CPAN documentation
111              
112             L
113              
114             =item * CPAN Ratings
115              
116             L
117              
118             =item * Search CPAN
119              
120             L
121              
122             =back
123              
124              
125             =head1 ACKNOWLEDGEMENTS
126              
127              
128             =head1 COPYRIGHT & LICENSE
129              
130             Copyright 2009 Darko Obradovic, all rights reserved.
131              
132             This program is free software; you can redistribute it and/or modify it
133             under the same terms as Perl itself.
134              
135              
136             =cut
137              
138             1; # End of SNA::Network::Generator::MCMC
139