File Coverage

blib/lib/SNA/Network/Filter/Pajek.pm
Criterion Covered Total %
statement 43 43 100.0
branch 11 16 68.7
condition 1 2 50.0
subroutine 8 8 100.0
pod 3 3 100.0
total 66 72 91.6


line stmt bran cond sub pod time code
1             package SNA::Network::Filter::Pajek;
2              
3 14     14   55 use warnings;
  14         19  
  14         398  
4 14     14   53 use strict;
  14         19  
  14         444  
5              
6             require Exporter;
7 14     14   57 use base qw(Exporter);
  14         17  
  14         2456  
8             our @EXPORT = qw(load_from_pajek_net new_from_pajek_net save_to_pajek_net);
9              
10 14     14   726 use Carp;
  14         685  
  14         1469  
11 14     14   1412 use English;
  14         687  
  14         1406  
12              
13              
14             =head1 NAME
15              
16             SNA::Network::Filter::Pajek - load and save networks from/to Pajek .net files
17              
18              
19             =head1 SYNOPSIS
20              
21             Quick summary of what the module does.
22              
23             Perhaps a little code snippet.
24              
25             use SNA::Network;
26              
27             my $net = SNA::Network->new();
28             $net->load_from_pajek_net($filename);
29             ...
30             # shortcut
31             my $net = SNA::Network->new_from_pajek_net($filename);
32             ...
33             $net->save_to_pajek_net($filename);
34              
35              
36             =head1 DESCRIPTION
37              
38             This enables import/export to the Pajek data format.
39             See L for details about the format.
40              
41              
42             =head1 METHODS
43              
44             The following methods are added to L.
45              
46             =head2 load_from_pajek_net
47              
48             load a network from a passed filename.
49             Nodes and edges are created as specified in the file, with the vertex name in the I field of the created nodes.
50              
51             =cut
52              
53             sub load_from_pajek_net {
54 14     14 1 122 my ($self, $filename) = @_;
55 14 50       714 open my $PAJEK_FILE, '<', $filename or croak "cannot open '$filename': $OS_ERROR\n";
56            
57 14         31 my $line;
58            
59             # search start of vertex definitions
60             START:
61 14         346 while (defined($line = <$PAJEK_FILE>)) {
62 14 50       118 last START if $line =~ m/\*Vertices/;
63             }
64            
65             # read vertices and create graph nodes
66             VERTICES:
67 14         104 while (defined($line = <$PAJEK_FILE>)) {
68 450 100       765 last VERTICES if $line =~ m/\*Arcs/;
69              
70 436 100       1379 $line =~ m/\s*(\d+)\s*(.*)/ or next VERTICES;
71 426         666 my ($node_number, $node_name) = ($1, $2);
72            
73 426         1050 $self->create_node_at_index(index => $node_number - 1, name => $node_name);
74             }
75            
76             # read arcs and create graph edges
77             EDGES:
78 14         62 while (defined($line = <$PAJEK_FILE>)) {
79 2998 100       9409 last EDGES unless $line =~ m/\s*(\d+)\s*(\d+)\s*(\d+)/;
80 2987         6562 my ($source_index, $target_index, $weight) = ($1 - 1, $2 - 1, $3);
81 2987         5308 $self->create_edge(
82             source_index => $source_index,
83             target_index => $target_index,
84             weight => $weight,
85             );
86             }
87              
88 14 50       257 close $PAJEK_FILE or croak "cannot close '$filename': $OS_ERROR\n";
89             }
90              
91              
92              
93             =head2 new_from_pajek_net
94              
95             Returns a newly created network from a passed filename.
96             Nodes and edges are created as specified in the file, with the vertex name in the I field of the created nodes.
97              
98             =cut
99              
100             sub new_from_pajek_net {
101 3     3 1 22 my ($package, $filename) = @_;
102 3         18 my $net = $package->new;
103 3         13 $net->load_from_pajek_net($filename);
104 3         15 return $net;
105             }
106              
107              
108              
109             =head2 save_to_pajek_net
110              
111             =cut
112              
113             sub save_to_pajek_net {
114 1     1 1 4 my ($self, $filename) = @_;
115              
116 1 50       198 open my $PAJEK_FILE, '>', $filename or croak "cannot open '$filename': $OS_ERROR\n";
117              
118             # process vertices
119 1         10 printf $PAJEK_FILE "*Vertices %d\n", int $self->nodes();
120 1         8 foreach my $node ($self->nodes()) {
121 4   50     25 printf $PAJEK_FILE "%d %s\n", $node->{index} + 1, $node->{name} || 'none';
122             }
123              
124 1         4 printf $PAJEK_FILE "*Arcs\n";
125 1         7 foreach my $arc ($self->edges()) {
126 6         58 printf $PAJEK_FILE "%d %d %d\n",
127             $arc->source()->index() + 1, $arc->target()->index() + 1, $arc->weight();
128             }
129            
130 1 50       87 close $PAJEK_FILE or croak "cannot close '$filename': $OS_ERROR\n";
131             }
132              
133              
134             =head1 AUTHOR
135              
136             Darko Obradovic, C<< >>
137              
138             =head1 BUGS
139              
140             Please report any bugs or feature requests to C, or through
141             the web interface at L. I will be notified, and then you'll
142             automatically be notified of progress on your bug as I make changes.
143              
144              
145              
146              
147             =head1 SUPPORT
148              
149             You can find documentation for this module with the perldoc command.
150              
151             perldoc SNA::Network
152              
153              
154             You can also look for information at:
155              
156             =over 4
157              
158             =item * RT: CPAN's request tracker
159              
160             L
161              
162             =item * AnnoCPAN: Annotated CPAN documentation
163              
164             L
165              
166             =item * CPAN Ratings
167              
168             L
169              
170             =item * Search CPAN
171              
172             L
173              
174             =back
175              
176              
177             =head1 COPYRIGHT & LICENSE
178              
179             Copyright 2009 Darko Obradovic, all rights reserved.
180              
181             This program is free software; you can redistribute it and/or modify it
182             under the same terms as Perl itself.
183              
184              
185             =cut
186              
187             1; # End of SNA::Network::Filter::Pajek