line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Graph::Dijkstra;
|
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
21639
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
4
|
1
|
|
|
1
|
|
5
|
use warnings;
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
32
|
|
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
5
|
use Carp qw(croak carp);
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
69
|
|
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
11557
|
use English qw(-no_match_vars);
|
|
1
|
|
|
|
|
25312
|
|
|
1
|
|
|
|
|
11
|
|
9
|
|
|
|
|
|
|
$OUTPUT_AUTOFLUSH=1;
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
972
|
use vars qw($VERSION);
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
123
|
|
13
|
|
|
|
|
|
|
$VERSION = '0.60';
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $VERBOSE = 0;
|
16
|
|
|
|
|
|
|
my $verboseOutfile = *STDOUT;
|
17
|
|
|
|
|
|
|
|
18
|
1
|
|
|
1
|
|
953
|
use Readonly;
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
Readonly my $EMPTY_STRING => q{};
|
21
|
|
|
|
|
|
|
Readonly my %IS_GRAPHML_WEIGHT_ATTR => map { ($_ => 1) } qw(weight value cost distance height);
|
22
|
|
|
|
|
|
|
Readonly my %IS_GRAPHML_LABEL_ATTR => map { ($_ => 1) } qw(label name description nlabel);
|
23
|
|
|
|
|
|
|
Readonly my $PINF => 1e9999; # positive infinity
|
24
|
|
|
|
|
|
|
Readonly my %GRAPH_ATTRIBUTES => (label=>$EMPTY_STRING, creator=>$EMPTY_STRING, edgedefault=>'undirected');
|
25
|
|
|
|
|
|
|
Readonly my %NODE_ATTRIBUTES => (label=>$EMPTY_STRING);
|
26
|
|
|
|
|
|
|
Readonly my %EDGE_ATTRIBUTES => (id=>$EMPTY_STRING, label=>$EMPTY_STRING, directed=>'undirected', weight=>0);
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
## no critic (PostfixControls)
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
#############################################################################
|
31
|
|
|
|
|
|
|
#used Modules #
|
32
|
|
|
|
|
|
|
#############################################################################
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
use Benchmark qw(:hireswallclock);
|
36
|
|
|
|
|
|
|
use Array::Heap::ModifiablePriorityQueue;
|
37
|
|
|
|
|
|
|
use Scalar::Util qw(looks_like_number);
|
38
|
|
|
|
|
|
|
use HTML::Entities qw(encode_entities);
|
39
|
|
|
|
|
|
|
use utf8;
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
#############################################################################
|
42
|
|
|
|
|
|
|
#Class Methods #
|
43
|
|
|
|
|
|
|
#############################################################################
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub verbose {
|
46
|
|
|
|
|
|
|
VERBOSE(@_);
|
47
|
|
|
|
|
|
|
}
|
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub VERBOSE {
|
50
|
|
|
|
|
|
|
my ($either, $verbose, $vOutfile) = @_;
|
51
|
|
|
|
|
|
|
return $VERBOSE if !defined($verbose);
|
52
|
|
|
|
|
|
|
$VERBOSE = $verbose;
|
53
|
|
|
|
|
|
|
print {$verboseOutfile} 'verbose output ', (($VERBOSE) ? 'set' : 'unset'), "\n";
|
54
|
|
|
|
|
|
|
if (defined($vOutfile) and (ref($vOutfile) eq 'GLOB' or ref($vOutfile) eq 'IO')) {
|
55
|
|
|
|
|
|
|
$verboseOutfile = $vOutfile;
|
56
|
|
|
|
|
|
|
print {$verboseOutfile} "verbose output redirected\n";
|
57
|
|
|
|
|
|
|
}
|
58
|
|
|
|
|
|
|
}
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub stringifyAttribs {
|
61
|
|
|
|
|
|
|
my ($either, $attribHref) = @_;
|
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
return if ref($attribHref) ne 'HASH';
|
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my $val = '';
|
66
|
|
|
|
|
|
|
foreach my $attrib (sort keys %$attribHref) {
|
67
|
|
|
|
|
|
|
$val .= ', ' if $val;
|
68
|
|
|
|
|
|
|
my $printval = (looks_like_number($attribHref->{$attrib})) ? "$attribHref->{$attrib}" : "'".encode_entities($attribHref->{$attrib})."'";
|
69
|
|
|
|
|
|
|
$val .= "$attrib=>$printval";
|
70
|
|
|
|
|
|
|
}
|
71
|
|
|
|
|
|
|
return "( $val )";
|
72
|
|
|
|
|
|
|
}
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sub hashifyAttribs {
|
75
|
|
|
|
|
|
|
my ($either, $attribStr) = @_;
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my %keyvals = ();
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
if ($attribStr =~ /^\(\s*(.+)\s*\)$/) {
|
80
|
|
|
|
|
|
|
$attribStr = $1;
|
81
|
|
|
|
|
|
|
}
|
82
|
|
|
|
|
|
|
while ($attribStr =~ /([a-z]+) => ([+-]? [0-9]+ (?: \. [0-9]+ )?+|(?:(?:\')(?:[^\\\']*(?:\\.[^\\\']*)*)(?:\')))/igx) {
|
83
|
|
|
|
|
|
|
my $id = $1;
|
84
|
|
|
|
|
|
|
my $val = $2;
|
85
|
|
|
|
|
|
|
$val = substr($val,1,-1) if substr($val,0,1) eq "'";
|
86
|
|
|
|
|
|
|
$keyvals{$id} = $val;
|
87
|
|
|
|
|
|
|
}
|
88
|
|
|
|
|
|
|
return \%keyvals;
|
89
|
|
|
|
|
|
|
}
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub _initialize {
|
93
|
|
|
|
|
|
|
my ($self, $options) = @_;
|
94
|
|
|
|
|
|
|
$self->{graph} = ();
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
foreach my $attrib (keys %GRAPH_ATTRIBUTES) {
|
97
|
|
|
|
|
|
|
$self->{$attrib} = $GRAPH_ATTRIBUTES{$attrib};
|
98
|
|
|
|
|
|
|
}
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
if (ref($options) eq 'HASH') {
|
101
|
|
|
|
|
|
|
foreach my $attrib (keys %$options) {
|
102
|
|
|
|
|
|
|
if (exists($GRAPH_ATTRIBUTES{$attrib})) {
|
103
|
|
|
|
|
|
|
$self->{$attrib} = $options->{$attrib};
|
104
|
|
|
|
|
|
|
}
|
105
|
|
|
|
|
|
|
else {
|
106
|
|
|
|
|
|
|
carp "new: unrecognized graph attribute '$attrib'";
|
107
|
|
|
|
|
|
|
}
|
108
|
|
|
|
|
|
|
}
|
109
|
|
|
|
|
|
|
}
|
110
|
|
|
|
|
|
|
return $self;
|
111
|
|
|
|
|
|
|
}
|
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub new {
|
114
|
|
|
|
|
|
|
my ($class, $options) = @_;
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
my $self = {};
|
117
|
|
|
|
|
|
|
bless $self, $class;
|
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
return $self->_initialize($options);
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
#return $self;
|
122
|
|
|
|
|
|
|
}
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
#############################################################################
|
126
|
|
|
|
|
|
|
#Graph Method(s) #
|
127
|
|
|
|
|
|
|
#############################################################################
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub graph {
|
130
|
|
|
|
|
|
|
my ($self, $options) = @_;
|
131
|
|
|
|
|
|
|
if (defined($options) and ref($options) eq 'HASH') { #SET method call
|
132
|
|
|
|
|
|
|
foreach my $attrib (keys %$options) {
|
133
|
|
|
|
|
|
|
if (exists($GRAPH_ATTRIBUTES{$attrib})) {
|
134
|
|
|
|
|
|
|
utf8::upgrade($options->{$attrib});
|
135
|
|
|
|
|
|
|
$self->{$attrib} = $options->{$attrib};
|
136
|
|
|
|
|
|
|
}
|
137
|
|
|
|
|
|
|
else {
|
138
|
|
|
|
|
|
|
carp "new: unrecognized graph attribute '$attrib'";
|
139
|
|
|
|
|
|
|
}
|
140
|
|
|
|
|
|
|
}
|
141
|
|
|
|
|
|
|
return $self;
|
142
|
|
|
|
|
|
|
}
|
143
|
|
|
|
|
|
|
#GET method call
|
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
return( {map { ($_ => $self->{$_} ) } (keys %GRAPH_ATTRIBUTES)} );
|
146
|
|
|
|
|
|
|
}
|
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
#############################################################################
|
149
|
|
|
|
|
|
|
#Node Methods #
|
150
|
|
|
|
|
|
|
#############################################################################
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub node {
|
153
|
|
|
|
|
|
|
my ($self, $nodeParam) = @_;
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
croak "node: missing nodeID / options parameter" if !defined($nodeParam);
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
if (ref($nodeParam) eq $EMPTY_STRING) { #GET method call
|
158
|
|
|
|
|
|
|
#my $nodeID = $nodeParam;
|
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeParam})) {
|
161
|
|
|
|
|
|
|
my %node = map { ($_ => $self->{graph}{$nodeParam}{$_} ) } (keys %NODE_ATTRIBUTES);
|
162
|
|
|
|
|
|
|
$node{id} = $nodeParam;
|
163
|
|
|
|
|
|
|
return( \%node );
|
164
|
|
|
|
|
|
|
}
|
165
|
|
|
|
|
|
|
return;
|
166
|
|
|
|
|
|
|
}
|
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
if (ref($nodeParam) eq 'HASH') { #SET method call
|
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
croak "node: missing \"id\" attribute in attributes hash" if !exists($nodeParam->{id});
|
171
|
|
|
|
|
|
|
my $nodeID = $nodeParam->{id};
|
172
|
|
|
|
|
|
|
croak "node: nodeID is not a SCALAR value" if ref($nodeID) ne $EMPTY_STRING;
|
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
if (!exists($self->{graph}{$nodeID})) { #set default node attribute values for new node
|
175
|
|
|
|
|
|
|
foreach my $attrib (keys %NODE_ATTRIBUTES) {
|
176
|
|
|
|
|
|
|
$self->{graph}{$nodeID}{$attrib} = $NODE_ATTRIBUTES{$attrib};
|
177
|
|
|
|
|
|
|
}
|
178
|
|
|
|
|
|
|
}
|
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
foreach my $attrib (keys %$nodeParam) { #update node attribute values from parameter values
|
181
|
|
|
|
|
|
|
if ( exists($NODE_ATTRIBUTES{$attrib}) ) {
|
182
|
|
|
|
|
|
|
utf8::upgrade($nodeParam->{$attrib});
|
183
|
|
|
|
|
|
|
$self->{graph}{$nodeID}{$attrib} = $nodeParam->{$attrib};
|
184
|
|
|
|
|
|
|
}
|
185
|
|
|
|
|
|
|
elsif ($attrib ne 'id') {
|
186
|
|
|
|
|
|
|
carp "node: unrecognized node attribute '$attrib'";
|
187
|
|
|
|
|
|
|
}
|
188
|
|
|
|
|
|
|
}
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
return $self;
|
191
|
|
|
|
|
|
|
}
|
192
|
|
|
|
|
|
|
croak "node: invalid parameter: must be either a nodeID (simple scalar) or an attributes hash (reference)";
|
193
|
|
|
|
|
|
|
}
|
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub nodeExists {
|
196
|
|
|
|
|
|
|
my ($self, $nodeID) = @_;
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
croak "nodeExists: missing nodeID parameter" if !defined($nodeID);
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
return (exists($self->{graph}{$nodeID})) ? 1 : 0;
|
201
|
|
|
|
|
|
|
}
|
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub nodeList {
|
205
|
|
|
|
|
|
|
my $self = shift;
|
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
my @nodeList = ();
|
208
|
|
|
|
|
|
|
foreach my $node (keys %{$self->{graph}}) {
|
209
|
|
|
|
|
|
|
push(@nodeList, { id=>$node, map {($_ => $self->{graph}{$node}{$_})} (keys %NODE_ATTRIBUTES) } );
|
210
|
|
|
|
|
|
|
}
|
211
|
|
|
|
|
|
|
return @nodeList;
|
212
|
|
|
|
|
|
|
}
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub removeNode {
|
216
|
|
|
|
|
|
|
my ($self, $nodeID) = @_;
|
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
croak "removeNode: missing nodeID parameter" if !defined($nodeID);
|
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID})) {
|
221
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
222
|
|
|
|
|
|
|
foreach my $targetID (sort keys %{$self->{graph}{$nodeID}{edges}}) {
|
223
|
|
|
|
|
|
|
delete($self->{graph}{$targetID}{edges}{$nodeID});
|
224
|
|
|
|
|
|
|
}
|
225
|
|
|
|
|
|
|
}
|
226
|
|
|
|
|
|
|
delete($self->{graph}{$nodeID});
|
227
|
|
|
|
|
|
|
return $self;
|
228
|
|
|
|
|
|
|
}
|
229
|
|
|
|
|
|
|
return;
|
230
|
|
|
|
|
|
|
}
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
#############################################################################
|
233
|
|
|
|
|
|
|
#Edge Methods #
|
234
|
|
|
|
|
|
|
#############################################################################
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub edge {
|
238
|
|
|
|
|
|
|
my ($self, $edgeHref) = @_;
|
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
croak "edge: missing parameter hash reference" if !defined($edgeHref) or ref($edgeHref) ne 'HASH';
|
241
|
|
|
|
|
|
|
croak "edge: parameter hash missing sourceID" if !exists($edgeHref->{sourceID});
|
242
|
|
|
|
|
|
|
croak "edge: parameter hash missing targetID" if !exists($edgeHref->{targetID});
|
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
my $sourceID = $edgeHref->{sourceID};
|
245
|
|
|
|
|
|
|
my $targetID = $edgeHref->{targetID};
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
#checks that apply to both set & get calls
|
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
if ($sourceID eq $targetID) {
|
250
|
|
|
|
|
|
|
carp 'edge: source and target node IDs must be different: ' . $self->stringifyAttribs( $edgeHref );
|
251
|
|
|
|
|
|
|
return;
|
252
|
|
|
|
|
|
|
}
|
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
if (!exists($self->{graph}{$sourceID})) {
|
255
|
|
|
|
|
|
|
carp "edge: sourceID $sourceID does not exist.";
|
256
|
|
|
|
|
|
|
return;
|
257
|
|
|
|
|
|
|
}
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
if (!exists($self->{graph}{$targetID})) {
|
260
|
|
|
|
|
|
|
carp "edge: targetID $targetID does not exist.";
|
261
|
|
|
|
|
|
|
return;
|
262
|
|
|
|
|
|
|
}
|
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
if (scalar(keys %$edgeHref) == 2) { #get method call, must be just sourceID, targetID
|
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
if (exists($self->{graph}{$sourceID}{edges}{$targetID})) {
|
268
|
|
|
|
|
|
|
return( {sourceID=>$sourceID, targetID=>$targetID, map { ($_ => $self->{graph}{$sourceID}{edges}{$targetID}{$_} ) } (keys %EDGE_ATTRIBUTES) } );
|
269
|
|
|
|
|
|
|
}
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
if (exists($self->{graph}{$sourceID}) and exists($self->{graph}{$targetID})) {
|
272
|
|
|
|
|
|
|
return( {sourceID=>$sourceID, targetID=>$targetID, weight=>0} );
|
273
|
|
|
|
|
|
|
}
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
if (!exists($self->{graph}{$sourceID})) {
|
276
|
|
|
|
|
|
|
carp "edge: sourceID $sourceID does not exist";
|
277
|
|
|
|
|
|
|
return;
|
278
|
|
|
|
|
|
|
}
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
carp "edge: targetID $targetID does not exist";
|
281
|
|
|
|
|
|
|
return;
|
282
|
|
|
|
|
|
|
}
|
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
#set method call
|
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
#directed value check
|
287
|
|
|
|
|
|
|
if (exists($edgeHref->{directed}) and ($edgeHref->{directed} ne 'directed' and $edgeHref->{directed} ne 'undirected')) {
|
288
|
|
|
|
|
|
|
carp "edge: unrecognized 'directed' attribute value '$edgeHref->{directed}'.";
|
289
|
|
|
|
|
|
|
return;
|
290
|
|
|
|
|
|
|
}
|
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
#weight value check
|
293
|
|
|
|
|
|
|
if (exists( $edgeHref->{weight} ) and (!looks_like_number($edgeHref->{weight}) or $edgeHref->{weight} <= 0)) {
|
294
|
|
|
|
|
|
|
carp "edge: invalid edge weight (cost) $edgeHref->{weight}.";
|
295
|
|
|
|
|
|
|
return;
|
296
|
|
|
|
|
|
|
}
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
if (exists($self->{graph}{$sourceID}{edges}{$targetID})) { #update existing edge
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
if (exists($edgeHref->{directed}) and $edgeHref->{directed} ne $self->{graph}{$sourceID}{edges}{$targetID}{directed}) {
|
301
|
|
|
|
|
|
|
carp "edge: cannot change directed value for existing edge $sourceID $targetID '$self->{graph}{$sourceID}{edges}{$targetID}{directed}'. To change edge directed value, remove and re-add.";
|
302
|
|
|
|
|
|
|
return;
|
303
|
|
|
|
|
|
|
}
|
304
|
|
|
|
|
|
|
my $edgeDirected = $self->{graph}{$sourceID}{edges}{$targetID}{directed};
|
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
foreach my $attrib (keys %$edgeHref) { #update node attribute values from parameter values
|
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
if ( exists($EDGE_ATTRIBUTES{$attrib}) ) {
|
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
utf8::upgrade($edgeHref->{$attrib}) if !looks_like_number($edgeHref->{$attrib});
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
$self->{graph}{$sourceID}{edges}{$targetID}{$attrib} = $edgeHref->{$attrib};
|
313
|
|
|
|
|
|
|
$self->{graph}{$targetID}{edges}{$sourceID}{$attrib} = $edgeHref->{$attrib} if $edgeDirected eq 'undirected';
|
314
|
|
|
|
|
|
|
}
|
315
|
|
|
|
|
|
|
elsif ($attrib ne 'sourceID' and $attrib ne 'targetID') {
|
316
|
|
|
|
|
|
|
carp "edge: unrecognized attribute '$attrib' not set";
|
317
|
|
|
|
|
|
|
}
|
318
|
|
|
|
|
|
|
}
|
319
|
|
|
|
|
|
|
return $self;
|
320
|
|
|
|
|
|
|
}
|
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
#create new edge
|
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
$edgeHref->{directed} = $self->{edgedefault} if !exists($edgeHref->{directed});
|
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
if ($edgeHref->{directed} eq 'undirected' and exists($self->{graph}{$targetID}{edges}{$sourceID}) and $self->{graph}{$targetID}{edges}{$sourceID}{directed} eq 'directed') {
|
327
|
|
|
|
|
|
|
carp "edge: $targetID $sourceID directed arc (edge) exists. Undirected edge $sourceID $targetID not created. Remove then add.";
|
328
|
|
|
|
|
|
|
return;
|
329
|
|
|
|
|
|
|
}
|
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
#set default attribute values
|
332
|
|
|
|
|
|
|
foreach my $attrib (keys %EDGE_ATTRIBUTES) {
|
333
|
|
|
|
|
|
|
$self->{graph}{$sourceID}{edges}{$targetID}{$attrib} = $EDGE_ATTRIBUTES{$attrib};
|
334
|
|
|
|
|
|
|
$self->{graph}{$targetID}{edges}{$sourceID}{$attrib} = $EDGE_ATTRIBUTES{$attrib} if $edgeHref->{directed} eq 'undirected';
|
335
|
|
|
|
|
|
|
}
|
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
foreach my $attrib (keys %$edgeHref) { #set edge attribute values from parameter values
|
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
next if ($attrib eq 'sourceID' or $attrib eq 'targetID');
|
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
if ( exists($EDGE_ATTRIBUTES{$attrib}) ) {
|
342
|
|
|
|
|
|
|
utf8::upgrade($edgeHref->{$attrib}) if !looks_like_number($attrib);
|
343
|
|
|
|
|
|
|
$self->{graph}{$sourceID}{edges}{$targetID}{$attrib} = $edgeHref->{$attrib};
|
344
|
|
|
|
|
|
|
$self->{graph}{$targetID}{edges}{$sourceID}{$attrib} = $edgeHref->{$attrib} if $edgeHref->{directed} eq 'undirected';
|
345
|
|
|
|
|
|
|
}
|
346
|
|
|
|
|
|
|
else {
|
347
|
|
|
|
|
|
|
carp "edge: unrecognized attribute '$attrib' not set";
|
348
|
|
|
|
|
|
|
}
|
349
|
|
|
|
|
|
|
}
|
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
return($self);
|
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
}
|
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub removeEdge {
|
357
|
|
|
|
|
|
|
my ($self, $edgeHref) = @_;
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
croak "removeEdge: missing parameter hash reference" if !defined($edgeHref);
|
360
|
|
|
|
|
|
|
croak "removeEdge: parameter hash missing sourceID" if !exists($edgeHref->{sourceID});
|
361
|
|
|
|
|
|
|
croak "removeEdge: parameter hash missing targetID" if !exists($edgeHref->{targetID});
|
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
my $sourceID = $edgeHref->{sourceID};
|
364
|
|
|
|
|
|
|
my $targetID = $edgeHref->{targetID};
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
if (exists($self->{graph}{$sourceID}{edges}{$targetID})) {
|
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
my $directed = $self->{graph}{$sourceID}{edges}{$targetID}{directed};
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
delete($self->{graph}{$sourceID}{edges}{$targetID});
|
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
my $hasNeighbors = 0;
|
373
|
|
|
|
|
|
|
foreach my $neighbor (keys %{$self->{graph}{$sourceID}{edges}}) {
|
374
|
|
|
|
|
|
|
$hasNeighbors = 1;
|
375
|
|
|
|
|
|
|
last;
|
376
|
|
|
|
|
|
|
}
|
377
|
|
|
|
|
|
|
if (!$hasNeighbors) {
|
378
|
|
|
|
|
|
|
delete($self->{graph}{$sourceID}{edges});
|
379
|
|
|
|
|
|
|
}
|
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
if ($directed eq 'undirected') { #remove $targetID $sourceID for undirected edges
|
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
delete($self->{graph}{$targetID}{edges}{$sourceID});
|
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
my $hasNeighbors = 0;
|
386
|
|
|
|
|
|
|
foreach my $neighbor (keys %{$self->{graph}{$targetID}{edges}}) {
|
387
|
|
|
|
|
|
|
$hasNeighbors = 1;
|
388
|
|
|
|
|
|
|
last;
|
389
|
|
|
|
|
|
|
}
|
390
|
|
|
|
|
|
|
if (!$hasNeighbors) {
|
391
|
|
|
|
|
|
|
delete($self->{graph}{$targetID}{edges});
|
392
|
|
|
|
|
|
|
}
|
393
|
|
|
|
|
|
|
}
|
394
|
|
|
|
|
|
|
}
|
395
|
|
|
|
|
|
|
else {
|
396
|
|
|
|
|
|
|
carp "removeEdge: no edge found for sourceID $sourceID and targetID $targetID";
|
397
|
|
|
|
|
|
|
}
|
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
return $self;
|
400
|
|
|
|
|
|
|
}
|
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
sub edgeExists {
|
405
|
|
|
|
|
|
|
my ($self, $edgeHref) = @_;
|
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
croak "edgeExists: missing parameter hash reference" if !defined($edgeHref);
|
408
|
|
|
|
|
|
|
croak "edgeExists: parameter hash missing sourceID" if !exists($edgeHref->{sourceID});
|
409
|
|
|
|
|
|
|
croak "edgeExists: parameter hash missing targetID" if !exists($edgeHref->{targetID});
|
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
my $sourceID = $edgeHref->{sourceID};
|
412
|
|
|
|
|
|
|
my $targetID = $edgeHref->{targetID};
|
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
return (exists($self->{graph}{$sourceID}{edges}{$targetID})) ? 1 : 0;
|
415
|
|
|
|
|
|
|
}
|
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub adjacent {
|
419
|
|
|
|
|
|
|
my ($self, $edgeHref) = @_;
|
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
croak "adjacent: missing parameter hash reference" if !defined($edgeHref);
|
422
|
|
|
|
|
|
|
croak "adjacent: parameter hash missing sourceID" if !exists($edgeHref->{sourceID});
|
423
|
|
|
|
|
|
|
croak "adjacent: parameter hash missing targetID" if !exists($edgeHref->{targetID});
|
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
my $sourceID = $edgeHref->{sourceID};
|
426
|
|
|
|
|
|
|
my $targetID = $edgeHref->{targetID};
|
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
return ( exists($self->{graph}{$sourceID}{edges}{$targetID}) ) ? 1 : 0;
|
429
|
|
|
|
|
|
|
}
|
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub adjacentNodes {
|
433
|
|
|
|
|
|
|
my ($self, $sourceID) = @_;
|
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
if (!defined($sourceID)) {
|
436
|
|
|
|
|
|
|
croak "adjacentNodes: missing node ID parameter";
|
437
|
|
|
|
|
|
|
}
|
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
my @neighbors = ();
|
440
|
|
|
|
|
|
|
if (exists($self->{graph}{$sourceID}{edges})) {
|
441
|
|
|
|
|
|
|
foreach my $targetID (sort keys %{$self->{graph}{$sourceID}{edges}}) {
|
442
|
|
|
|
|
|
|
push(@neighbors, $targetID);
|
443
|
|
|
|
|
|
|
}
|
444
|
|
|
|
|
|
|
print "crap\n" if scalar(@neighbors) == 0;
|
445
|
|
|
|
|
|
|
}
|
446
|
|
|
|
|
|
|
else {
|
447
|
|
|
|
|
|
|
print {$verboseOutfile} "adjacentNodes: node $sourceID has no outbound edges\n" if $VERBOSE;
|
448
|
|
|
|
|
|
|
}
|
449
|
|
|
|
|
|
|
return @neighbors;
|
450
|
|
|
|
|
|
|
}
|
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
#############################################################################
|
455
|
|
|
|
|
|
|
#Dijkstra Computation Methods #
|
456
|
|
|
|
|
|
|
#############################################################################
|
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
#Computes Jordan center by creating all pairs shortest path matrix
|
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
sub vertexCenter {
|
461
|
|
|
|
|
|
|
my ($self, $solutionMatrix) = @_;
|
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
%$solutionMatrix = ();
|
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
my @connectedNodeList = ();
|
466
|
|
|
|
|
|
|
my $nodesEdgeCount = 0;
|
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
my $totalNodes = 0;
|
469
|
|
|
|
|
|
|
foreach my $nodeID ( keys %{$self->{graph}} ) {
|
470
|
|
|
|
|
|
|
$totalNodes++;
|
471
|
|
|
|
|
|
|
$nodesEdgeCount++ if exists($self->{graph}{$nodeID}{edges});
|
472
|
|
|
|
|
|
|
push(@connectedNodeList, $nodeID);
|
473
|
|
|
|
|
|
|
}
|
474
|
|
|
|
|
|
|
my $nodeCount = scalar(@connectedNodeList);
|
475
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenter: graph contains $totalNodes nodes, $nodesEdgeCount nodes have one or more outbound edges\n" if $VERBOSE;
|
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
foreach my $fromNodeID (@connectedNodeList) {
|
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
$solutionMatrix->{rowMax}{$fromNodeID} = $PINF;
|
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
foreach my $toNodeID (@connectedNodeList) {
|
482
|
|
|
|
|
|
|
$solutionMatrix->{row}{$fromNodeID}{$toNodeID} = $PINF;
|
483
|
|
|
|
|
|
|
}
|
484
|
|
|
|
|
|
|
$solutionMatrix->{row}{$fromNodeID}{$fromNodeID} = 0;
|
485
|
|
|
|
|
|
|
}
|
486
|
|
|
|
|
|
|
my $hasDirectedEdges = 0;
|
487
|
|
|
|
|
|
|
foreach my $nodeID (@connectedNodeList) {
|
488
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
489
|
|
|
|
|
|
|
if ($self->{graph}{$nodeID}{edges}{$targetID}{directed} eq 'directed') {
|
490
|
|
|
|
|
|
|
$hasDirectedEdges = 1;
|
491
|
|
|
|
|
|
|
last;
|
492
|
|
|
|
|
|
|
}
|
493
|
|
|
|
|
|
|
}
|
494
|
|
|
|
|
|
|
last if $hasDirectedEdges;
|
495
|
|
|
|
|
|
|
}
|
496
|
|
|
|
|
|
|
my $matrixComputations = ($totalNodes * $totalNodes) - $totalNodes;
|
497
|
|
|
|
|
|
|
if ($nodesEdgeCount < $totalNodes) {
|
498
|
|
|
|
|
|
|
my $nodesNoEdges = $totalNodes - $nodesEdgeCount;
|
499
|
|
|
|
|
|
|
$matrixComputations -= $nodesNoEdges * ($totalNodes - 1);
|
500
|
|
|
|
|
|
|
}
|
501
|
|
|
|
|
|
|
$matrixComputations = $matrixComputations / 2 if !$hasDirectedEdges;
|
502
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenter: graph has directed edges. Computing shortest path for A -> C and C -> A separately.\n" if $hasDirectedEdges and $VERBOSE;
|
503
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenter: graph has no directed edges. Shortest path for A -> C and C -> A are same.\n" if !$hasDirectedEdges and $VERBOSE;
|
504
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenter: performing $matrixComputations shortest path computations.\n" if $VERBOSE;
|
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
#should add code to limit computations at reasonable number
|
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
my $cycle = 0;
|
509
|
|
|
|
|
|
|
my $t0 = Benchmark->new;
|
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
foreach my $origin (@connectedNodeList) {
|
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
next if !exists($self->{graph}{$origin}{edges}); #skip origin nodes that have no outbound edges, all paths are infinite
|
514
|
|
|
|
|
|
|
#print '.';
|
515
|
|
|
|
|
|
|
foreach my $destination (@connectedNodeList) {
|
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
next if $solutionMatrix->{row}{$origin}{$destination} < $PINF or $origin eq $destination;
|
518
|
|
|
|
|
|
|
#print "shortest path $origin -> $destination...";
|
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
my $pq = Array::Heap::ModifiablePriorityQueue->new();
|
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
my %solution = ();
|
523
|
|
|
|
|
|
|
my %unvisited = ();
|
524
|
|
|
|
|
|
|
foreach my $node (@connectedNodeList) {
|
525
|
|
|
|
|
|
|
next if $node ne $destination and !exists($self->{graph}{$node}{edges}); #solution cannot include intermediate nodes with no outbound edges
|
526
|
|
|
|
|
|
|
$solution{$node}{weight} = $PINF;
|
527
|
|
|
|
|
|
|
$pq->add($node, $PINF);
|
528
|
|
|
|
|
|
|
}
|
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
$solution{$origin}{weight} = 0;
|
531
|
|
|
|
|
|
|
$pq->add($origin,0); #modify weight of origin node
|
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
#my $foundSolution = 0;
|
535
|
|
|
|
|
|
|
while ($pq->size()) {
|
536
|
|
|
|
|
|
|
$cycle++;
|
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
my $visitNode = $pq->get();
|
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
$solutionMatrix->{row}{$origin}{$visitNode} = $solution{$visitNode}{weight};
|
541
|
|
|
|
|
|
|
$solutionMatrix->{row}{$visitNode}{$origin} = $solution{$visitNode}{weight} if !$hasDirectedEdges;
|
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
last if ($visitNode eq $destination);
|
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# next if !exists($self->{graph}{$visitNode}{edges});
|
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
foreach my $adjacentNode (keys %{$self->{graph}{$visitNode}{edges}}) {
|
548
|
|
|
|
|
|
|
next if !defined($pq->weight($adjacentNode));
|
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
my $thisWeight = $solution{$visitNode}{weight} + $self->{graph}{$visitNode}{edges}{$adjacentNode}{weight};
|
551
|
|
|
|
|
|
|
if ($thisWeight < $solution{$adjacentNode}{weight}) {
|
552
|
|
|
|
|
|
|
$solution{$adjacentNode}{weight} = $thisWeight;
|
553
|
|
|
|
|
|
|
# $solution{$adjacentNode}{prevnode} = $visitNode;
|
554
|
|
|
|
|
|
|
$pq->add($adjacentNode, $thisWeight);
|
555
|
|
|
|
|
|
|
}
|
556
|
|
|
|
|
|
|
}
|
557
|
|
|
|
|
|
|
}
|
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
undef($pq);
|
560
|
|
|
|
|
|
|
}
|
561
|
|
|
|
|
|
|
}
|
562
|
|
|
|
|
|
|
#print "\n cycles=$cycle\n";
|
563
|
|
|
|
|
|
|
if ($VERBOSE) {
|
564
|
|
|
|
|
|
|
my $t1 = Benchmark->new;
|
565
|
|
|
|
|
|
|
#if ($cycle >= 1000) {
|
566
|
|
|
|
|
|
|
# print "\n";
|
567
|
|
|
|
|
|
|
#}
|
568
|
|
|
|
|
|
|
my $td = timediff($t1, $t0);
|
569
|
|
|
|
|
|
|
print {$verboseOutfile} "computing shortest path matrix took: ",timestr($td),"\n";
|
570
|
|
|
|
|
|
|
}
|
571
|
|
|
|
|
|
|
my $graphMinMax = $PINF;
|
572
|
|
|
|
|
|
|
my $centerNode = '';
|
573
|
|
|
|
|
|
|
foreach my $origin (@connectedNodeList) {
|
574
|
|
|
|
|
|
|
my $rowMax = 0;
|
575
|
|
|
|
|
|
|
foreach my $destination (@connectedNodeList) {
|
576
|
|
|
|
|
|
|
next if $origin eq $destination;
|
577
|
|
|
|
|
|
|
if ($solutionMatrix->{row}{$origin}{$destination} > $rowMax) {
|
578
|
|
|
|
|
|
|
$rowMax = $solutionMatrix->{row}{$origin}{$destination};
|
579
|
|
|
|
|
|
|
}
|
580
|
|
|
|
|
|
|
}
|
581
|
|
|
|
|
|
|
$solutionMatrix->{rowMax}{$origin} = $rowMax;
|
582
|
|
|
|
|
|
|
if ($rowMax < $graphMinMax) {
|
583
|
|
|
|
|
|
|
$graphMinMax = $rowMax;
|
584
|
|
|
|
|
|
|
}
|
585
|
|
|
|
|
|
|
}
|
586
|
|
|
|
|
|
|
$solutionMatrix->{centerNodeSet} = [];
|
587
|
|
|
|
|
|
|
if ($graphMinMax < $PINF) {
|
588
|
|
|
|
|
|
|
foreach my $origin (@connectedNodeList) {
|
589
|
|
|
|
|
|
|
if ($solutionMatrix->{rowMax}{$origin} == $graphMinMax) {
|
590
|
|
|
|
|
|
|
push(@{$solutionMatrix->{centerNodeSet}}, $origin);
|
591
|
|
|
|
|
|
|
}
|
592
|
|
|
|
|
|
|
}
|
593
|
|
|
|
|
|
|
}
|
594
|
|
|
|
|
|
|
else {
|
595
|
|
|
|
|
|
|
carp "vertexCenter: Graph contains disconnected sub-graph / non-reachable node pairs. Center node set undefined.";
|
596
|
|
|
|
|
|
|
$graphMinMax = 0;
|
597
|
|
|
|
|
|
|
}
|
598
|
|
|
|
|
|
|
#print "centernodeset ", join(',', @{$solutionMatrix->{centerNodeSet}}), "\n";
|
599
|
|
|
|
|
|
|
return($graphMinMax);
|
600
|
|
|
|
|
|
|
}
|
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
sub farthestNode { ## no critic (ProhibitExcessComplexity)
|
603
|
|
|
|
|
|
|
my ($self, $solutionHref) = @_;
|
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
if (!exists($solutionHref->{originID})) {
|
606
|
|
|
|
|
|
|
croak "farthestNode: originID attribute not set in solution hash reference parameter";
|
607
|
|
|
|
|
|
|
}
|
608
|
|
|
|
|
|
|
my $originID = $solutionHref->{originID};
|
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
if (!exists($self->{graph}{$originID})) {
|
611
|
|
|
|
|
|
|
carp "farthestNode: originID not found: $originID";
|
612
|
|
|
|
|
|
|
return 0;
|
613
|
|
|
|
|
|
|
}
|
614
|
|
|
|
|
|
|
elsif (!exists($self->{graph}{$originID}{edges})) {
|
615
|
|
|
|
|
|
|
carp "farthestNode: origin node $originID has no edges";
|
616
|
|
|
|
|
|
|
return 0;
|
617
|
|
|
|
|
|
|
}
|
618
|
|
|
|
|
|
|
my $pq = Array::Heap::ModifiablePriorityQueue->new();
|
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
my %solution = (); #initialize the solution hash
|
621
|
|
|
|
|
|
|
my %unvisited = ();
|
622
|
|
|
|
|
|
|
foreach my $node (keys %{$self->{graph}}) {
|
623
|
|
|
|
|
|
|
# if (exists($self->{graph}{$node}{edges})) { #nodes without edges cannot be part of the solution
|
624
|
|
|
|
|
|
|
$solution{$node}{weight} = $PINF;
|
625
|
|
|
|
|
|
|
$solution{$node}{prevnode} = $EMPTY_STRING;
|
626
|
|
|
|
|
|
|
$pq->add($node, $PINF);
|
627
|
|
|
|
|
|
|
# }
|
628
|
|
|
|
|
|
|
}
|
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
$solution{$originID}{weight} = 0;
|
631
|
|
|
|
|
|
|
$pq->add($originID,0); #modify weight of origin node
|
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
my $cycle = 0;
|
634
|
|
|
|
|
|
|
my $t0 = Benchmark->new;
|
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
while ($pq->size()) {
|
637
|
|
|
|
|
|
|
$cycle++;
|
638
|
|
|
|
|
|
|
#print '.' if $VERBOSE and ($cycle % 1000 == 0);
|
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
my $visitNode = $pq->get();
|
641
|
|
|
|
|
|
|
next if !exists($self->{graph}{$visitNode}{edges});
|
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
foreach my $adjacentNode (keys %{$self->{graph}{$visitNode}{edges}}) {
|
644
|
|
|
|
|
|
|
next if !defined($pq->weight($adjacentNode));
|
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
my $thisWeight = $solution{$visitNode}{weight} + $self->{graph}{$visitNode}{edges}{$adjacentNode}{weight};
|
647
|
|
|
|
|
|
|
if ($thisWeight < $solution{$adjacentNode}{weight}) {
|
648
|
|
|
|
|
|
|
$solution{$adjacentNode}{weight} = $thisWeight;
|
649
|
|
|
|
|
|
|
$solution{$adjacentNode}{prevnode} = $visitNode;
|
650
|
|
|
|
|
|
|
$pq->add($adjacentNode, $thisWeight);
|
651
|
|
|
|
|
|
|
}
|
652
|
|
|
|
|
|
|
}
|
653
|
|
|
|
|
|
|
}
|
654
|
|
|
|
|
|
|
if ($VERBOSE) {
|
655
|
|
|
|
|
|
|
my $t1 = Benchmark->new;
|
656
|
|
|
|
|
|
|
#if ($cycle >= 1000) {
|
657
|
|
|
|
|
|
|
# print "\n";
|
658
|
|
|
|
|
|
|
#}
|
659
|
|
|
|
|
|
|
my $td = timediff($t1, $t0);
|
660
|
|
|
|
|
|
|
print {$verboseOutfile} "dijkstra's algorithm took: ",timestr($td),"\n";
|
661
|
|
|
|
|
|
|
}
|
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
my $farthestWeight = 0;
|
664
|
|
|
|
|
|
|
foreach my $node (sort keys %solution) {
|
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
if ($solution{$node}{weight} < $PINF and $solution{$node}{weight} > $farthestWeight) {
|
667
|
|
|
|
|
|
|
$farthestWeight = $solution{$node}{weight};
|
668
|
|
|
|
|
|
|
#$farthestnode = $node;
|
669
|
|
|
|
|
|
|
}
|
670
|
|
|
|
|
|
|
}
|
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
croak "farthestNode: path weight to farthest node is 0" if $farthestWeight == 0;
|
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
my $solutioncnt = 0;
|
676
|
|
|
|
|
|
|
%{$solutionHref} = (
|
677
|
|
|
|
|
|
|
desc => 'farthest',
|
678
|
|
|
|
|
|
|
originID => $originID,
|
679
|
|
|
|
|
|
|
weight => $farthestWeight,
|
680
|
|
|
|
|
|
|
);
|
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
foreach my $farthestnode (sort keys %solution) {
|
683
|
|
|
|
|
|
|
if ($solution{$farthestnode}{weight} == $farthestWeight) {
|
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
$solutioncnt++;
|
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
print {$verboseOutfile} "\nfarthestNode: (solution $solutioncnt) farthest node from origin $originID is $farthestnode at weight (cost) $farthestWeight\n" if $VERBOSE;
|
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
my $fromNode = $solution{$farthestnode}{prevnode};
|
690
|
|
|
|
|
|
|
my @path = ( $farthestnode, $fromNode );
|
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
my %loopCheck = ();
|
693
|
|
|
|
|
|
|
while ($solution{$fromNode}{prevnode} ne $EMPTY_STRING) {
|
694
|
|
|
|
|
|
|
$fromNode = $solution{$fromNode}{prevnode};
|
695
|
|
|
|
|
|
|
if (exists($loopCheck{$fromNode})) {
|
696
|
|
|
|
|
|
|
print STDERR "farthestNode: path loop at $fromNode\n";
|
697
|
|
|
|
|
|
|
print STDERR 'farthestNode: path = ', join(',',@path), "\n";
|
698
|
|
|
|
|
|
|
die 'farthestNode internal error: destination to origin path logic error';
|
699
|
|
|
|
|
|
|
}
|
700
|
|
|
|
|
|
|
$loopCheck{$fromNode} = 1;
|
701
|
|
|
|
|
|
|
push(@path,$fromNode);
|
702
|
|
|
|
|
|
|
}
|
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
@path = reverse(@path);
|
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
my $nexttolast = $#path - 1;
|
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
$solutionHref->{path}{$solutioncnt}{destinationID} = $farthestnode;
|
709
|
|
|
|
|
|
|
$solutionHref->{path}{$solutioncnt}{edges} = [];
|
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
foreach my $i (0 .. $nexttolast) {
|
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
push(@{$solutionHref->{path}{$solutioncnt}{edges}}, {sourceID => $path[$i], targetID => $path[$i+1], weight => $self->edge( { sourceID=>$path[$i], targetID=>$path[$i+1] } )->{weight} } );
|
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
}
|
716
|
|
|
|
|
|
|
}
|
717
|
|
|
|
|
|
|
}
|
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
$solutionHref->{count} = $solutioncnt;
|
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
return($farthestWeight);
|
722
|
|
|
|
|
|
|
}
|
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
sub shortestPath { ## no critic (ProhibitExcessComplexity)
|
725
|
|
|
|
|
|
|
my ($self, $solutionHref) = @_;
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
if (!exists($solutionHref->{originID})) {
|
728
|
|
|
|
|
|
|
croak "farthestNode: originID attribute not set in solution hash reference parameter";
|
729
|
|
|
|
|
|
|
}
|
730
|
|
|
|
|
|
|
my $originID = $solutionHref->{originID};
|
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
if (!exists($solutionHref->{destinationID})) {
|
733
|
|
|
|
|
|
|
croak "farthestNode: destinationID attribute not set in solution hash reference parameter";
|
734
|
|
|
|
|
|
|
}
|
735
|
|
|
|
|
|
|
my $destinationID = $solutionHref->{destinationID};
|
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
if (!exists($self->{graph}{$originID})) {
|
738
|
|
|
|
|
|
|
carp "shortestPath: originID not found: $originID";
|
739
|
|
|
|
|
|
|
return 0;
|
740
|
|
|
|
|
|
|
}
|
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
if (!exists($self->{graph}{$originID}{edges})) {
|
743
|
|
|
|
|
|
|
carp "shortestPath: origin node $originID has no edges";
|
744
|
|
|
|
|
|
|
return 0;
|
745
|
|
|
|
|
|
|
}
|
746
|
|
|
|
|
|
|
if (!exists($self->{graph}{$destinationID})) {
|
747
|
|
|
|
|
|
|
carp "shortestPath: destinationID not found: $destinationID";
|
748
|
|
|
|
|
|
|
return 0;
|
749
|
|
|
|
|
|
|
}
|
750
|
|
|
|
|
|
|
# if (!exists($self->{graph}{$destinationID}{edges})) {
|
751
|
|
|
|
|
|
|
# carp "shortestPath: destination node $destinationID has no edges";
|
752
|
|
|
|
|
|
|
# return 0;
|
753
|
|
|
|
|
|
|
# }
|
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
my $pq = Array::Heap::ModifiablePriorityQueue->new();
|
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
my %solution = (); #initialize the solution hash
|
758
|
|
|
|
|
|
|
my %unvisited = ();
|
759
|
|
|
|
|
|
|
foreach my $node (keys %{$self->{graph}}) {
|
760
|
|
|
|
|
|
|
# if (exists($self->{graph}{$node}{edges})) { #nodes without edges cannot be part of the solution
|
761
|
|
|
|
|
|
|
$solution{$node}{weight} = $PINF;
|
762
|
|
|
|
|
|
|
$solution{$node}{prevnode} = $EMPTY_STRING;
|
763
|
|
|
|
|
|
|
$pq->add($node, $PINF);
|
764
|
|
|
|
|
|
|
# }
|
765
|
|
|
|
|
|
|
}
|
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
$solution{$originID}{weight} = 0;
|
768
|
|
|
|
|
|
|
$pq->add($originID,0); #modify weight of origin node
|
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
my $cycle = 0;
|
771
|
|
|
|
|
|
|
my $t0 = Benchmark->new;
|
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
my $foundSolution = 0;
|
774
|
|
|
|
|
|
|
while ($pq->size()) {
|
775
|
|
|
|
|
|
|
$cycle++;
|
776
|
|
|
|
|
|
|
#print '.' if $VERBOSE and ($cycle % 1000 == 0);
|
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
my $visitNode = $pq->get();
|
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
if ($visitNode eq $destinationID) {
|
781
|
|
|
|
|
|
|
$foundSolution = 1 if $solution{$visitNode}{weight} < $PINF;
|
782
|
|
|
|
|
|
|
last;
|
783
|
|
|
|
|
|
|
}
|
784
|
|
|
|
|
|
|
next if !exists($self->{graph}{$visitNode}{edges});
|
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
foreach my $adjacentNode (keys %{$self->{graph}{$visitNode}{edges}}) {
|
787
|
|
|
|
|
|
|
next if !defined($pq->weight($adjacentNode));
|
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
my $thisWeight = $solution{$visitNode}{weight} + $self->{graph}{$visitNode}{edges}{$adjacentNode}{weight};
|
790
|
|
|
|
|
|
|
if ($thisWeight < $solution{$adjacentNode}{weight}) {
|
791
|
|
|
|
|
|
|
$solution{$adjacentNode}{weight} = $thisWeight;
|
792
|
|
|
|
|
|
|
$solution{$adjacentNode}{prevnode} = $visitNode;
|
793
|
|
|
|
|
|
|
$pq->add($adjacentNode, $thisWeight);
|
794
|
|
|
|
|
|
|
}
|
795
|
|
|
|
|
|
|
}
|
796
|
|
|
|
|
|
|
}
|
797
|
|
|
|
|
|
|
if ($VERBOSE) {
|
798
|
|
|
|
|
|
|
my $t1 = Benchmark->new;
|
799
|
|
|
|
|
|
|
#if ($cycle >= 1000) {
|
800
|
|
|
|
|
|
|
# print "\n";
|
801
|
|
|
|
|
|
|
#}
|
802
|
|
|
|
|
|
|
my $td = timediff($t1, $t0);
|
803
|
|
|
|
|
|
|
print "dijkstra's algorithm took: ",timestr($td),"\n";
|
804
|
|
|
|
|
|
|
}
|
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
my $pathWeight = 0;
|
807
|
|
|
|
|
|
|
if ($foundSolution) {
|
808
|
|
|
|
|
|
|
$pathWeight = $solution{$destinationID}{weight};
|
809
|
|
|
|
|
|
|
print {$verboseOutfile} "shortestPath: originID $originID -> destinationID $destinationID pathWeight (cost) = $pathWeight\n" if $VERBOSE;
|
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
my $solutioncnt = 0;
|
812
|
|
|
|
|
|
|
%{$solutionHref} = (
|
813
|
|
|
|
|
|
|
desc => 'path',
|
814
|
|
|
|
|
|
|
originID => $originID,
|
815
|
|
|
|
|
|
|
destinationID => $destinationID,
|
816
|
|
|
|
|
|
|
weight => $pathWeight,
|
817
|
|
|
|
|
|
|
);
|
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
my $fromNode = $solution{$destinationID}{prevnode};
|
820
|
|
|
|
|
|
|
my @path = ( $destinationID, $fromNode );
|
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
my %loopCheck = ();
|
823
|
|
|
|
|
|
|
while ($solution{$fromNode}{prevnode} ne $EMPTY_STRING) {
|
824
|
|
|
|
|
|
|
$fromNode = $solution{$fromNode}{prevnode};
|
825
|
|
|
|
|
|
|
if (exists($loopCheck{$fromNode})) {
|
826
|
|
|
|
|
|
|
print "shortestPath: path loop at $fromNode\n";
|
827
|
|
|
|
|
|
|
print "shortestPath: path = ", join(',',@path), "\n";
|
828
|
|
|
|
|
|
|
die "shortestPath internal error: destination to origin path logic error";
|
829
|
|
|
|
|
|
|
}
|
830
|
|
|
|
|
|
|
$loopCheck{$fromNode} = 1;
|
831
|
|
|
|
|
|
|
push(@path,$fromNode);
|
832
|
|
|
|
|
|
|
}
|
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
@path = reverse(@path);
|
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
my $nexttolast = $#path - 1;
|
837
|
|
|
|
|
|
|
foreach my $i (0 .. $nexttolast) {
|
838
|
|
|
|
|
|
|
push(@{$solutionHref->{edges}}, {sourceID => $path[$i], targetID => $path[$i+1], weight => $self->edge( { sourceID=>$path[$i], targetID=>$path[$i+1] } )->{weight} } );
|
839
|
|
|
|
|
|
|
}
|
840
|
|
|
|
|
|
|
}
|
841
|
|
|
|
|
|
|
return($pathWeight);
|
842
|
|
|
|
|
|
|
}
|
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
#############################################################################
|
845
|
|
|
|
|
|
|
#Floyd Warshall alternative method #
|
846
|
|
|
|
|
|
|
#############################################################################
|
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
sub vertexCenterFloydWarshall {
|
849
|
|
|
|
|
|
|
my ($self, $solutionMatrix) = @_;
|
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
%$solutionMatrix = ();
|
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
my @nodeList = ();
|
854
|
|
|
|
|
|
|
my $nodesEdgeCount = 0;
|
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
my $totalNodes = 0;
|
857
|
|
|
|
|
|
|
foreach my $nodeID ( keys %{$self->{graph}} ) {
|
858
|
|
|
|
|
|
|
$totalNodes++;
|
859
|
|
|
|
|
|
|
$nodesEdgeCount++ if exists($self->{graph}{$nodeID}{edges});
|
860
|
|
|
|
|
|
|
push(@nodeList, $nodeID);
|
861
|
|
|
|
|
|
|
}
|
862
|
|
|
|
|
|
|
my $nodeCount = scalar(@nodeList);
|
863
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenterFloydWarshall: graph contains $totalNodes nodes, $nodesEdgeCount nodes have one or more outbound edges\n" if $VERBOSE;
|
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
#should add code to limit computations at reasonable number
|
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
my $t0 = Benchmark->new;
|
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
foreach my $fromNodeID (@nodeList) {
|
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
$solutionMatrix->{rowMax}{$fromNodeID} = $PINF;
|
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
foreach my $toNodeID (@nodeList) {
|
874
|
|
|
|
|
|
|
$solutionMatrix->{row}{$fromNodeID}{$toNodeID} = $PINF;
|
875
|
|
|
|
|
|
|
}
|
876
|
|
|
|
|
|
|
$solutionMatrix->{row}{$fromNodeID}{$fromNodeID} = 0;
|
877
|
|
|
|
|
|
|
}
|
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
foreach my $fromNodeID (@nodeList) {
|
880
|
|
|
|
|
|
|
next if !exists($self->{graph}{$fromNodeID}{edges});
|
881
|
|
|
|
|
|
|
foreach my $toNodeID (keys %{$self->{graph}{$fromNodeID}{edges}}) {
|
882
|
|
|
|
|
|
|
$solutionMatrix->{row}{$fromNodeID}{$toNodeID} = $self->{graph}{$fromNodeID}{edges}{$toNodeID}{weight};
|
883
|
|
|
|
|
|
|
$solutionMatrix->{row}{$toNodeID}{$fromNodeID} = $solutionMatrix->{row}{$fromNodeID}{$toNodeID} if $self->{graph}{$fromNodeID}{edges}{$toNodeID}{directed} eq 'undirected';
|
884
|
|
|
|
|
|
|
}
|
885
|
|
|
|
|
|
|
}
|
886
|
|
|
|
|
|
|
foreach my $k (@nodeList) {
|
887
|
|
|
|
|
|
|
next if !exists($self->{graph}{$k}{edges});
|
888
|
|
|
|
|
|
|
foreach my $i (@nodeList) {
|
889
|
|
|
|
|
|
|
next if !exists($self->{graph}{$i}{edges});
|
890
|
|
|
|
|
|
|
foreach my $j (@nodeList) {
|
891
|
|
|
|
|
|
|
next if $i eq $j;
|
892
|
|
|
|
|
|
|
if ($solutionMatrix->{row}{$i}{$j} > ($solutionMatrix->{row}{$i}{$k} + $solutionMatrix->{row}{$k}{$j})) {
|
893
|
|
|
|
|
|
|
$solutionMatrix->{row}{$i}{$j} = $solutionMatrix->{row}{$i}{$k} + $solutionMatrix->{row}{$k}{$j};
|
894
|
|
|
|
|
|
|
}
|
895
|
|
|
|
|
|
|
}
|
896
|
|
|
|
|
|
|
}
|
897
|
|
|
|
|
|
|
}
|
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
if ($VERBOSE) {
|
900
|
|
|
|
|
|
|
my $t1 = Benchmark->new;
|
901
|
|
|
|
|
|
|
#if ($cycle >= 1000) {
|
902
|
|
|
|
|
|
|
# print "\n";
|
903
|
|
|
|
|
|
|
#}
|
904
|
|
|
|
|
|
|
my $td = timediff($t1, $t0);
|
905
|
|
|
|
|
|
|
print {$verboseOutfile} "vertexCenterFloydWarshall: computing shortest path matrix took: ",timestr($td),"\n";
|
906
|
|
|
|
|
|
|
}
|
907
|
|
|
|
|
|
|
my $graphMinMax = $PINF;
|
908
|
|
|
|
|
|
|
my $centerNode = '';
|
909
|
|
|
|
|
|
|
foreach my $origin (@nodeList) {
|
910
|
|
|
|
|
|
|
my $rowMax = 0;
|
911
|
|
|
|
|
|
|
foreach my $destination (@nodeList) {
|
912
|
|
|
|
|
|
|
next if $origin eq $destination;
|
913
|
|
|
|
|
|
|
if ($solutionMatrix->{row}{$origin}{$destination} > $rowMax) {
|
914
|
|
|
|
|
|
|
$rowMax = $solutionMatrix->{row}{$origin}{$destination};
|
915
|
|
|
|
|
|
|
}
|
916
|
|
|
|
|
|
|
}
|
917
|
|
|
|
|
|
|
$solutionMatrix->{rowMax}{$origin} = $rowMax;
|
918
|
|
|
|
|
|
|
if ($rowMax < $graphMinMax) {
|
919
|
|
|
|
|
|
|
$graphMinMax = $rowMax;
|
920
|
|
|
|
|
|
|
}
|
921
|
|
|
|
|
|
|
}
|
922
|
|
|
|
|
|
|
$solutionMatrix->{centerNodeSet} = [];
|
923
|
|
|
|
|
|
|
if ($graphMinMax < $PINF) {
|
924
|
|
|
|
|
|
|
foreach my $origin (@nodeList) {
|
925
|
|
|
|
|
|
|
if ($solutionMatrix->{rowMax}{$origin} == $graphMinMax) {
|
926
|
|
|
|
|
|
|
push(@{$solutionMatrix->{centerNodeSet}}, $origin);
|
927
|
|
|
|
|
|
|
}
|
928
|
|
|
|
|
|
|
}
|
929
|
|
|
|
|
|
|
}
|
930
|
|
|
|
|
|
|
else {
|
931
|
|
|
|
|
|
|
carp "vertexCenterFloydWarshall: Graph contains disconnected sub-graph / non-reachable node pairs. Center node set undefined.";
|
932
|
|
|
|
|
|
|
$graphMinMax = 0;
|
933
|
|
|
|
|
|
|
}
|
934
|
|
|
|
|
|
|
return($graphMinMax);
|
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
}
|
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
#############################################################################
|
939
|
|
|
|
|
|
|
#input / output file methods #
|
940
|
|
|
|
|
|
|
#############################################################################
|
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
{ #CSV file format methods
|
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
use Text::CSV_XS;
|
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
sub getRowHref {
|
947
|
|
|
|
|
|
|
my $row = shift;
|
948
|
|
|
|
|
|
|
my $attribStr = $EMPTY_STRING;
|
949
|
|
|
|
|
|
|
foreach my $i (1 .. $#$row) {
|
950
|
|
|
|
|
|
|
$attribStr .= ', ' if $attribStr;
|
951
|
|
|
|
|
|
|
$attribStr .= $row->[$i];
|
952
|
|
|
|
|
|
|
}
|
953
|
|
|
|
|
|
|
return Graph::Dijkstra->hashifyAttribs( "($attribStr)" );
|
954
|
|
|
|
|
|
|
}
|
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
sub inputGraphfromCSV {
|
957
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
if (!ref($self)) {
|
960
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
961
|
|
|
|
|
|
|
}
|
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
my $nodecount = 0;
|
964
|
|
|
|
|
|
|
my $edgecount = 0;
|
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
open(my $infile, '<:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromCSV: opened '$filename' for input\n" if $VERBOSE;
|
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
my $csv = Text::CSV_XS->new ({ binary => 1, auto_diag => 1 });
|
971
|
|
|
|
|
|
|
while (my $row = $csv->getline ($infile)) {
|
972
|
|
|
|
|
|
|
if (lc($row->[0]) eq 'graph') {
|
973
|
|
|
|
|
|
|
$self->graph( getRowHref( $row ) ) if $#$row;
|
974
|
|
|
|
|
|
|
}
|
975
|
|
|
|
|
|
|
elsif (lc($row->[0]) eq 'node') {
|
976
|
|
|
|
|
|
|
$self->node( getRowHref( $row ) );
|
977
|
|
|
|
|
|
|
$nodecount++;
|
978
|
|
|
|
|
|
|
}
|
979
|
|
|
|
|
|
|
elsif (lc($row->[0]) eq 'edge') {
|
980
|
|
|
|
|
|
|
$self->edge( getRowHref( $row ) );
|
981
|
|
|
|
|
|
|
$edgecount++;
|
982
|
|
|
|
|
|
|
}
|
983
|
|
|
|
|
|
|
}
|
984
|
|
|
|
|
|
|
close($infile);
|
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
carp "inputGraphfromCSV: no nodes read from '$filename'" if !$nodecount;
|
987
|
|
|
|
|
|
|
carp "inputGraphfromCSV: no edges read from '$filename'" if !$edgecount;
|
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromCSV: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
990
|
|
|
|
|
|
|
return $self;
|
991
|
|
|
|
|
|
|
}
|
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
sub makeRow {
|
994
|
|
|
|
|
|
|
my $href = shift;
|
995
|
|
|
|
|
|
|
my @rowdata = ();
|
996
|
|
|
|
|
|
|
foreach my $attrib (sort keys %$href) {
|
997
|
|
|
|
|
|
|
next if $href->{$attrib} eq $EMPTY_STRING;
|
998
|
|
|
|
|
|
|
my $printVal = (looks_like_number($href->{$attrib})) ? $href->{$attrib} : "'$href->{$attrib}'";
|
999
|
|
|
|
|
|
|
push(@rowdata, "$attrib=>$printVal");
|
1000
|
|
|
|
|
|
|
}
|
1001
|
|
|
|
|
|
|
return @rowdata;
|
1002
|
|
|
|
|
|
|
}
|
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
sub outputGraphtoCSV {
|
1005
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
open(my $outfile, '>:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoCSV: opened '$filename' for output\n" if $VERBOSE;
|
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
my $csv = Text::CSV_XS->new ({ binary => 1, auto_diag => 1 });
|
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
my $nodecount = 0;
|
1014
|
|
|
|
|
|
|
my $edgecount = 0;
|
1015
|
|
|
|
|
|
|
my $graphHref = $self->graph();
|
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
$csv->say( $outfile, ['graph', makeRow( $self->graph() ) ] );
|
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
my $graphDirected = $self->{edgedefault};
|
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
my %edges = ();
|
1022
|
|
|
|
|
|
|
foreach my $nodeID (keys %{$self->{graph}}) {
|
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
$csv->say($outfile, ['node', makeRow( $self->node($nodeID) ) ]);
|
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
$nodecount++;
|
1027
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
1028
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
1029
|
|
|
|
|
|
|
my $edgeDirected = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
1030
|
|
|
|
|
|
|
if ( ($edgeDirected eq 'undirected' and !exists($edges{$targetID}{$nodeID})) or $edgeDirected eq 'directed') {
|
1031
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
1032
|
|
|
|
|
|
|
}
|
1033
|
|
|
|
|
|
|
}
|
1034
|
|
|
|
|
|
|
}
|
1035
|
|
|
|
|
|
|
}
|
1036
|
|
|
|
|
|
|
foreach my $sourceID (keys %edges) {
|
1037
|
|
|
|
|
|
|
foreach my $targetID (keys %{$edges{$sourceID}}) {
|
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
$csv->say($outfile, ['edge', makeRow( $self->edge( {sourceID=>$sourceID, targetID=>$targetID} ) ) ]);
|
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
$edgecount++;
|
1042
|
|
|
|
|
|
|
}
|
1043
|
|
|
|
|
|
|
}
|
1044
|
|
|
|
|
|
|
close($outfile);
|
1045
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoCSV: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
return $self;
|
1048
|
|
|
|
|
|
|
}
|
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
sub outputAPSPmatrixtoCSV {
|
1051
|
|
|
|
|
|
|
my ($either, $solutionMatrix, $filename, $labelSort) = @_;
|
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
$labelSort = '' if !defined($labelSort);
|
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
open(my $outfile, '>:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
print {$verboseOutfile} "outputAPSPmatrixtoCSV: opened '$filename' for output\n" if $VERBOSE;
|
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
my $csv = Text::CSV_XS->new ({ binary => 1, auto_diag => 1 });
|
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
my @nodeList = (lc($labelSort) eq 'numeric') ? (sort {$a <=> $b} keys %{$solutionMatrix->{row}}) : (sort keys %{$solutionMatrix->{row}});
|
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
$csv->say($outfile, ['From/To', @nodeList ]);
|
1064
|
|
|
|
|
|
|
my $rowcount = 1;
|
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
foreach my $nodeID (@nodeList) {
|
1067
|
|
|
|
|
|
|
my @row = ();
|
1068
|
|
|
|
|
|
|
foreach my $destinationID (@nodeList) {
|
1069
|
|
|
|
|
|
|
push(@row, $solutionMatrix->{row}{$nodeID}{$destinationID});
|
1070
|
|
|
|
|
|
|
}
|
1071
|
|
|
|
|
|
|
$csv->say($outfile, [$nodeID, @row]);
|
1072
|
|
|
|
|
|
|
$rowcount++;
|
1073
|
|
|
|
|
|
|
}
|
1074
|
|
|
|
|
|
|
close($outfile);
|
1075
|
|
|
|
|
|
|
print {$verboseOutfile} "outputAPSPmatrixtoCSV: wrote $rowcount rows to '$filename'\n" if $VERBOSE;
|
1076
|
|
|
|
|
|
|
return $either;
|
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
}
|
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
} #CSV file format I/O methods
|
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
#############################################################################
|
1083
|
|
|
|
|
|
|
#JSON Graph Specification file format methods #
|
1084
|
|
|
|
|
|
|
#############################################################################
|
1085
|
|
|
|
|
|
|
{
|
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
use JSON;
|
1088
|
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
|
sub inputGraphfromJSON {
|
1090
|
|
|
|
|
|
|
my ($self, $filename, $options) = @_;
|
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
if (!ref($self)) {
|
1093
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
1094
|
|
|
|
|
|
|
}
|
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
my $json_text = $EMPTY_STRING;
|
1097
|
|
|
|
|
|
|
open(my $infile, '<:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromJSON: opened '$filename' for input\n" if $VERBOSE;
|
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
while (my $line = <$infile>) {
|
1102
|
|
|
|
|
|
|
$json_text .= $line;
|
1103
|
|
|
|
|
|
|
}
|
1104
|
|
|
|
|
|
|
close($infile);
|
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
my $graphHref = from_json( $json_text, {utf8 => 1} ) or croak "inputGraphfromJSON: invalid json text";
|
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
if (ref($graphHref) ne 'HASH') {
|
1109
|
|
|
|
|
|
|
croak "inputGraphfromJSON: invalid JSON text";
|
1110
|
|
|
|
|
|
|
}
|
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
if (exists($graphHref->{graphs})) {
|
1113
|
|
|
|
|
|
|
croak "inputGraphfromJSON: JSON \"multi graph\" type not supported";
|
1114
|
|
|
|
|
|
|
}
|
1115
|
|
|
|
|
|
|
if (!exists($graphHref->{graph}{edges})) {
|
1116
|
|
|
|
|
|
|
croak "inputGraphfromJSON: not a JSON graph specification or graph has no edges";
|
1117
|
|
|
|
|
|
|
}
|
1118
|
|
|
|
|
|
|
my $edgeWeightKey = (defined($options) and ref($options) eq 'HASH' and exists($options->{edgeWeightKey})) ? $options->{edgeWeightKey} : 'value';
|
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
my $graphDirected = 'undirected';
|
1121
|
|
|
|
|
|
|
if (exists($graphHref->{graph}{directed}) and $graphHref->{graph}{directed} ) {
|
1122
|
|
|
|
|
|
|
$graphDirected = 'directed';
|
1123
|
|
|
|
|
|
|
}
|
1124
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromJSON: graph edge default is '$graphDirected'.\n" if $VERBOSE;
|
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
$self->graph( {label=>$graphHref->{graph}{label} } ) if exists($graphHref->{graph}{label});
|
1127
|
|
|
|
|
|
|
$self->graph( {creator=>$graphHref->{graph}{metadata}{creator} } ) if exists($graphHref->{graph}{metadata}{creator});
|
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
my $nodecount = 0;
|
1130
|
|
|
|
|
|
|
my $edgecount = 0;
|
1131
|
|
|
|
|
|
|
my $dupedgecount = 0;
|
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
foreach my $nodeHref (@{$graphHref->{graph}{nodes}}) {
|
1134
|
|
|
|
|
|
|
$nodecount++;
|
1135
|
|
|
|
|
|
|
$self->node( {id=>$nodeHref->{id}, label=>$nodeHref->{label} } );
|
1136
|
|
|
|
|
|
|
}
|
1137
|
|
|
|
|
|
|
foreach my $edgeHref (@{$graphHref->{graph}{edges}}) {
|
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
my $edgeDirected = $graphDirected;
|
1140
|
|
|
|
|
|
|
if (exists($edgeHref->{directed})) {
|
1141
|
|
|
|
|
|
|
$edgeDirected = ($edgeHref->{directed}) ? 'directed' : 'undirected';
|
1142
|
|
|
|
|
|
|
}
|
1143
|
|
|
|
|
|
|
my $edgeLabel = $edgeHref->{label} || $EMPTY_STRING;
|
1144
|
|
|
|
|
|
|
my $edgeID = $edgeHref->{metadata}{id} || $EMPTY_STRING;
|
1145
|
|
|
|
|
|
|
my $weight = $edgeHref->{metadata}{$edgeWeightKey} || 1;
|
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
$edgecount++;
|
1148
|
|
|
|
|
|
|
$dupedgecount++ if $self->edgeExists( { sourceID=>$edgeHref->{source}, targetID=>$edgeHref->{target} } );
|
1149
|
|
|
|
|
|
|
$self->edge( { sourceID=>$edgeHref->{source}, targetID=>$edgeHref->{target}, weight=>$weight, label=>$edgeLabel, directed=>$edgeDirected, id=>$edgeID } );
|
1150
|
|
|
|
|
|
|
}
|
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
carp "inputGraphfromJSON: no nodes read from '$filename'" if !$nodecount;
|
1153
|
|
|
|
|
|
|
carp "inputGraphfromJSON: no edges read from '$filename'" if !$edgecount;
|
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromJSON: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
1156
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromJSON: found $dupedgecount duplicate edges\n" if $dupedgecount and $VERBOSE;
|
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
return $self;
|
1159
|
|
|
|
|
|
|
}
|
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
sub outputGraphtoJSON {
|
1163
|
|
|
|
|
|
|
my ($self, $filename, $options) = @_;
|
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
my $nodecount = 0;
|
1166
|
|
|
|
|
|
|
my $edgecount = 0;
|
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
my %graph = ();
|
1169
|
|
|
|
|
|
|
my $graphDirected = $self->{edgedefault};
|
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
$graph{graph}{directed} = ($graphDirected eq 'directed') ? JSON::true : JSON::false;
|
1172
|
|
|
|
|
|
|
@{$graph{graph}{nodes}} = ();
|
1173
|
|
|
|
|
|
|
@{$graph{graph}{edges}} = ();
|
1174
|
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
|
$graph{graph}{metadata}{comment} = 'generated by Graph::Dijkstra on ' . localtime;
|
1176
|
|
|
|
|
|
|
$graph{graph}{label} = $self->{label} if $self->{label};
|
1177
|
|
|
|
|
|
|
$graph{graph}{metadata}{creator} = $self->{creator} if $self->{creator};
|
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
my $edgeWeightKey = (defined($options) and ref($options) eq 'HASH' and exists($options->{edgeWeightKey})) ? $options->{edgeWeightKey} : 'value';
|
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
my %edges = ();
|
1182
|
|
|
|
|
|
|
foreach my $nodeID (keys %{$self->{graph}}) {
|
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
push(@{$graph{graph}{nodes}}, { id => $nodeID, label => $self->{graph}{$nodeID}{label} } );
|
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
$nodecount++;
|
1187
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
1188
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
my $edgeDirected = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
1191
|
|
|
|
|
|
|
if ( ($edgeDirected eq 'undirected' and !exists($edges{$targetID}{$nodeID})) or $edgeDirected eq 'directed') {
|
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID} = 1;
|
1194
|
|
|
|
|
|
|
my %edgeData = ( source => $nodeID, target => $targetID, metadata => {$edgeWeightKey => $self->{graph}{$nodeID}{edges}{$targetID}{weight} } );
|
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
$edgeData{label} = $self->{graph}{$nodeID}{edges}{$targetID}{label} if $self->{graph}{$nodeID}{edges}{$targetID}{label};
|
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
if ($edgeDirected ne $graphDirected) {
|
1199
|
|
|
|
|
|
|
$edgeData{directed} = ($edgeDirected eq 'directed') ? JSON::true : JSON::false;
|
1200
|
|
|
|
|
|
|
}
|
1201
|
|
|
|
|
|
|
if ($self->{graph}{$nodeID}{edges}{$targetID}{id} ne $EMPTY_STRING) {
|
1202
|
|
|
|
|
|
|
$edgeData{metadata}{id} = $self->{graph}{$nodeID}{edges}{$targetID}{id};
|
1203
|
|
|
|
|
|
|
}
|
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
push( @{$graph{graph}{edges}}, \%edgeData );
|
1206
|
|
|
|
|
|
|
$edgecount++;
|
1207
|
|
|
|
|
|
|
}
|
1208
|
|
|
|
|
|
|
}
|
1209
|
|
|
|
|
|
|
}
|
1210
|
|
|
|
|
|
|
}
|
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
my $json_text = to_json(\%graph, {utf8 => 1, pretty => 1});
|
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
open(my $outfile, '>:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoJSON: opened '$filename' for output\n" if $VERBOSE;
|
1217
|
|
|
|
|
|
|
print {$outfile} $json_text;
|
1218
|
|
|
|
|
|
|
close($outfile);
|
1219
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoJSON: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
return $self;
|
1222
|
|
|
|
|
|
|
}
|
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
} #JSON Graph Specification file format methods
|
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
#############################################################################
|
1227
|
|
|
|
|
|
|
#GML file format methods #
|
1228
|
|
|
|
|
|
|
#############################################################################
|
1229
|
|
|
|
|
|
|
{
|
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
use Regexp::Common;
|
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
sub inputGraphfromGML { ## no critic (ProhibitExcessComplexity)
|
1234
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
if (!ref($self)) {
|
1237
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
1238
|
|
|
|
|
|
|
}
|
1239
|
|
|
|
|
|
|
my $buffer = $EMPTY_STRING;
|
1240
|
|
|
|
|
|
|
my $linecount = 0;
|
1241
|
|
|
|
|
|
|
open(my $infile, '<:encoding(UTF-8)', $filename) or croak "could not open '$filename'";
|
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: opened '$filename' for input\n" if $VERBOSE;
|
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
while (my $line = <$infile>) {
|
1246
|
|
|
|
|
|
|
next if substr($line,0,1) eq '#';
|
1247
|
|
|
|
|
|
|
$buffer .= $line;
|
1248
|
|
|
|
|
|
|
$linecount++;
|
1249
|
|
|
|
|
|
|
}
|
1250
|
|
|
|
|
|
|
close($infile);
|
1251
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: read $linecount lines\n" if $VERBOSE;
|
1252
|
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
|
if ($buffer !~ /graph\s+\[.+?(?:node|edge)\s+\[/ixs) {
|
1254
|
|
|
|
|
|
|
croak "file does not appear to be GML format";
|
1255
|
|
|
|
|
|
|
}
|
1256
|
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
|
my $graphDirected = 'undirected';
|
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
if ($buffer =~ /graph\s+\[\s+directed\s+(\d)/ixs) {
|
1260
|
|
|
|
|
|
|
$graphDirected = ($1) ? 'directed' : 'undirected';
|
1261
|
|
|
|
|
|
|
}
|
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: graph edge default = '$graphDirected'\n" if $VERBOSE;
|
1264
|
|
|
|
|
|
|
$self->graph( { edgedefault=>$graphDirected } );
|
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
if ($buffer =~ /^\s*creator\s+\"([^\"]+)\"/i) {
|
1267
|
|
|
|
|
|
|
my $creator = $1;
|
1268
|
|
|
|
|
|
|
$self->graph( {creator=>$creator} );
|
1269
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: graph attribute creator set: $creator\n" if $VERBOSE;
|
1270
|
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
}
|
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
my $has_graphics_elements = ($buffer =~ /graphics\s+\[/) ? 1 : 0;
|
1274
|
|
|
|
|
|
|
print {$verboseOutfile} "GML file contain graphics elements\n" if ($VERBOSE and $has_graphics_elements);
|
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
my $balancedRE = $RE{balanced}{-parens=>'[]'};
|
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
|
1279
|
|
|
|
|
|
|
my $nodecount = 0;
|
1280
|
|
|
|
|
|
|
my $edgecount = 0;
|
1281
|
|
|
|
|
|
|
my $dupedgecount = 0;
|
1282
|
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
|
while ($buffer =~ /(node|edge)\s+$balancedRE/gixso) {
|
1284
|
|
|
|
|
|
|
my $type = lc($1);
|
1285
|
|
|
|
|
|
|
my $attribs = $2;
|
1286
|
|
|
|
|
|
|
#my $bufferPos = $-[0];
|
1287
|
|
|
|
|
|
|
|
1288
|
|
|
|
|
|
|
$attribs = substr($attribs, 1, -1);
|
1289
|
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
|
$attribs =~ s/graphics\s+$balancedRE//xio if $has_graphics_elements and $type eq 'node';
|
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
my %keyvals = ();
|
1293
|
|
|
|
|
|
|
while ($attribs =~/(id|label|source|target|value)\s+(?|([0-9\.]+)|\"([^\"]+)\")/gixs) {
|
1294
|
|
|
|
|
|
|
my $attrib = lc($1);
|
1295
|
|
|
|
|
|
|
my $attribValue = $2;
|
1296
|
|
|
|
|
|
|
if ($type eq 'edge' and $attrib eq 'value' and !looks_like_number($attribValue)) {
|
1297
|
|
|
|
|
|
|
carp "non-numeric edge value '$attribValue'. Skipped.";
|
1298
|
|
|
|
|
|
|
next;
|
1299
|
|
|
|
|
|
|
}
|
1300
|
|
|
|
|
|
|
$keyvals{$attrib} = $attribValue;
|
1301
|
|
|
|
|
|
|
}
|
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
if ($type eq 'node') {
|
1304
|
|
|
|
|
|
|
$nodecount++;
|
1305
|
|
|
|
|
|
|
if (exists($keyvals{id})) {
|
1306
|
|
|
|
|
|
|
$self->{graph}{$keyvals{id}}{label} = $keyvals{label} || $EMPTY_STRING;
|
1307
|
|
|
|
|
|
|
}
|
1308
|
|
|
|
|
|
|
else {
|
1309
|
|
|
|
|
|
|
croak "inputGraphfromGML: node: missing id problem -- matched attribs: '$attribs'";
|
1310
|
|
|
|
|
|
|
}
|
1311
|
|
|
|
|
|
|
}
|
1312
|
|
|
|
|
|
|
else {
|
1313
|
|
|
|
|
|
|
$edgecount++;
|
1314
|
|
|
|
|
|
|
my $edgeLabel = $keyvals{label} || $EMPTY_STRING;
|
1315
|
|
|
|
|
|
|
if (exists($keyvals{source}) and exists($keyvals{target}) and exists($keyvals{value}) and $keyvals{value} > 0) {
|
1316
|
|
|
|
|
|
|
$dupedgecount++ if $self->edgeExists( { sourceID=>$keyvals{source}, targetID=>$keyvals{target} } );
|
1317
|
|
|
|
|
|
|
$self->edge( { sourceID=>$keyvals{source}, targetID=>$keyvals{target}, weight=>$keyvals{value}, label=>$edgeLabel, directed=>$graphDirected } );
|
1318
|
|
|
|
|
|
|
}
|
1319
|
|
|
|
|
|
|
else {
|
1320
|
|
|
|
|
|
|
croak "inputGraphfromGML: edge: missing source, target, value, or value <= 0 problem -- matched attribs '$attribs'";
|
1321
|
|
|
|
|
|
|
}
|
1322
|
|
|
|
|
|
|
}
|
1323
|
|
|
|
|
|
|
}
|
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
carp "inputGraphfromGML: no nodes read from '$filename'" if !$nodecount;
|
1326
|
|
|
|
|
|
|
carp "inputGraphfromGML: no edges read from '$filename'" if !$edgecount;
|
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
1329
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGML: found $dupedgecount duplicate edges\n" if $dupedgecount and $VERBOSE;
|
1330
|
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
|
return $self;
|
1332
|
|
|
|
|
|
|
}
|
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
sub outputGraphtoGML {
|
1336
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
open(my $outfile, '>:encoding(UTF-8)', $filename) or croak "could not open '$filename' for output";
|
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoGML: opened '$filename' for output\n" if $VERBOSE;
|
1341
|
|
|
|
|
|
|
|
1342
|
|
|
|
|
|
|
{
|
1343
|
|
|
|
|
|
|
my $now_string = localtime;
|
1344
|
|
|
|
|
|
|
print {$outfile} "# Generated by Graph::Dijkstra on $now_string\n";
|
1345
|
|
|
|
|
|
|
}
|
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
print {$outfile} "Creator \"$self->{creator}\"\n" if $self->{creator};
|
1348
|
|
|
|
|
|
|
my $graphDirected = ($self->{edgedefault} eq 'directed') ? 1 : 0;
|
1349
|
|
|
|
|
|
|
print {$outfile} "Graph [\n\tDirected ", (($self->{edgedefault} eq 'directed') ? 1 : 0), "\n";
|
1350
|
|
|
|
|
|
|
$graphDirected = $self->{edgedefault};
|
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
my $nodecount = 0;
|
1353
|
|
|
|
|
|
|
my $edgecount = 0;
|
1354
|
|
|
|
|
|
|
|
1355
|
|
|
|
|
|
|
my %edges = ();
|
1356
|
|
|
|
|
|
|
foreach my $nodeID (keys %{$self->{graph}}) {
|
1357
|
|
|
|
|
|
|
my $nodeIDprint = (looks_like_number($nodeID)) ? $nodeID : '"' . encode_entities($nodeID) . '"';
|
1358
|
|
|
|
|
|
|
my $nodeLabel = encode_entities($self->{graph}{$nodeID}{label});
|
1359
|
|
|
|
|
|
|
print {$outfile} "\tnode [\n\t\tid $nodeIDprint\n\t\tlabel \"$nodeLabel\"\n\t]\n";
|
1360
|
|
|
|
|
|
|
$nodecount++;
|
1361
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
1362
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
1363
|
|
|
|
|
|
|
croak "outputGraphtoGML: internal graph includes both directed and undirected edges. Not supported by GML format." if $self->{graph}{$nodeID}{edges}{$targetID}{directed} ne $graphDirected;
|
1364
|
|
|
|
|
|
|
if ( ($graphDirected eq 'undirected' and !exists($edges{$targetID}{$nodeID})) or $graphDirected eq 'directed') {
|
1365
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
1366
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{label} = $self->{graph}{$nodeID}{edges}{$targetID}{label};
|
1367
|
|
|
|
|
|
|
}
|
1368
|
|
|
|
|
|
|
}
|
1369
|
|
|
|
|
|
|
}
|
1370
|
|
|
|
|
|
|
}
|
1371
|
|
|
|
|
|
|
foreach my $sourceID (keys %edges) {
|
1372
|
|
|
|
|
|
|
foreach my $targetID (keys %{$edges{$sourceID}}) {
|
1373
|
|
|
|
|
|
|
my $sourceIDprint = (looks_like_number($sourceID)) ? $sourceID : '"' . encode_entities($sourceID) . '"';
|
1374
|
|
|
|
|
|
|
my $targetIDprint = (looks_like_number($targetID)) ? $targetID : '"' . encode_entities($targetID) . '"';
|
1375
|
|
|
|
|
|
|
my $edgeLabelprint = ($edges{$sourceID}{$targetID}{label}) ? "\t\tlabel \"" . encode_entities($edges{$sourceID}{$targetID}{label}) . "\"\n" : $EMPTY_STRING;
|
1376
|
|
|
|
|
|
|
print {$outfile} "\tedge [\n\t\tsource $sourceIDprint\n\t\ttarget $targetIDprint\n$edgeLabelprint\t\tvalue $edges{$sourceID}{$targetID}{weight}\n\t]\n";
|
1377
|
|
|
|
|
|
|
$edgecount++;
|
1378
|
|
|
|
|
|
|
}
|
1379
|
|
|
|
|
|
|
}
|
1380
|
|
|
|
|
|
|
print {$outfile} "]\n";
|
1381
|
|
|
|
|
|
|
close($outfile);
|
1382
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoGML: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
return $self;
|
1385
|
|
|
|
|
|
|
}
|
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
} #GML file format methods
|
1388
|
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
|
#############################################################################
|
1390
|
|
|
|
|
|
|
#XML file format methods: GraphML and GEXF #
|
1391
|
|
|
|
|
|
|
#############################################################################
|
1392
|
|
|
|
|
|
|
{
|
1393
|
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
|
use XML::LibXML;
|
1395
|
|
|
|
|
|
|
|
1396
|
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
|
sub inputGraphfromGraphML { ## no critic (ProhibitExcessComplexity)
|
1398
|
|
|
|
|
|
|
my ($self, $filename, $options) = @_;
|
1399
|
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
if (!ref($self)) {
|
1401
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
1402
|
|
|
|
|
|
|
}
|
1403
|
|
|
|
|
|
|
|
1404
|
|
|
|
|
|
|
my $dom = XML::LibXML->load_xml(location => $filename);
|
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: input '$filename'\n" if $VERBOSE;
|
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
my $topNode = $dom->nonBlankChildNodes()->[0];
|
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: not a GraphML format XML file" if lc($topNode->nodeName()) ne 'graphml';
|
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
my $nsURI = $topNode->getAttribute('xmlns') || '';
|
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: not a GraphML format XML file" if (lc($nsURI) ne 'http://graphml.graphdrawing.org/xmlns');
|
1415
|
|
|
|
|
|
|
|
1416
|
|
|
|
|
|
|
my $xpc = XML::LibXML::XPathContext->new($dom);
|
1417
|
|
|
|
|
|
|
$xpc->registerNs('gml', $nsURI);
|
1418
|
|
|
|
|
|
|
|
1419
|
|
|
|
|
|
|
my $labelKey = $options->{nodeKeyLabelID} || $EMPTY_STRING;
|
1420
|
|
|
|
|
|
|
my $weightKey = $options->{edgeKeyValueID} || $EMPTY_STRING;
|
1421
|
|
|
|
|
|
|
my $edgeLabelKey = 'label';
|
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
my $defaultWeight = 1;
|
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
my $nodecount = 0;
|
1426
|
|
|
|
|
|
|
my $dupnodecount = 0;
|
1427
|
|
|
|
|
|
|
my $edgecount = 0;
|
1428
|
|
|
|
|
|
|
my $badedgecount = 0;
|
1429
|
|
|
|
|
|
|
my $dupedgecount = 0;
|
1430
|
|
|
|
|
|
|
my $graphDirected = $EMPTY_STRING;
|
1431
|
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
|
if (my $graphNode = $xpc->findnodes('/gml:graphml/gml:graph')->[0] ) {
|
1433
|
|
|
|
|
|
|
$graphDirected = lc($graphNode->getAttribute('edgedefault'));
|
1434
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: graph edge default is '$graphDirected'.\n" if $VERBOSE;
|
1435
|
|
|
|
|
|
|
}
|
1436
|
|
|
|
|
|
|
else {
|
1437
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: GraphML file has no element";
|
1438
|
|
|
|
|
|
|
}
|
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
if (my $graphNode = $xpc->findnodes('/gml:graphml/gml:graph[2]')->[0] ) {
|
1441
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: file contains more than one graph. Not supported.";
|
1442
|
|
|
|
|
|
|
}
|
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
if (my $graphNode = $xpc->findnodes('/gml:graphml/gml:graph/gml:node/gml:graph')->[0] ) {
|
1445
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: file contains one or more embedded graphs. Not supported.";
|
1446
|
|
|
|
|
|
|
}
|
1447
|
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
|
if ($weightKey) {
|
1449
|
|
|
|
|
|
|
if (my $keyWeightNode = $xpc->findnodes("/gml:graphml/gml:key[\@for=\"edge\" and \@id=\"$weightKey\"]")->[0]) {
|
1450
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found edgeKeyWeightID '$weightKey' in GraphML key elements list\n" if $VERBOSE;
|
1451
|
|
|
|
|
|
|
if (my $defaultNode = $xpc->findnodes('.//gml:default[1]',$keyWeightNode)->[0]) {
|
1452
|
|
|
|
|
|
|
$defaultWeight = $defaultNode->textContent();
|
1453
|
|
|
|
|
|
|
}
|
1454
|
|
|
|
|
|
|
}
|
1455
|
|
|
|
|
|
|
else {
|
1456
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: edgeKeyValueID '$weightKey' not found in GraphML key elements list";
|
1457
|
|
|
|
|
|
|
$weightKey = $EMPTY_STRING;
|
1458
|
|
|
|
|
|
|
}
|
1459
|
|
|
|
|
|
|
}
|
1460
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
if (!$weightKey) {
|
1462
|
|
|
|
|
|
|
foreach my $keyEdge ($xpc->findnodes('/gml:graphml/gml:key[@for="edge"]') ) {
|
1463
|
|
|
|
|
|
|
my $attrName = $keyEdge->getAttribute('attr.name');
|
1464
|
|
|
|
|
|
|
if ($IS_GRAPHML_WEIGHT_ATTR{ lc($attrName) } ) {
|
1465
|
|
|
|
|
|
|
$weightKey = $keyEdge->getAttribute('id');
|
1466
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found key attribute for edge attr.name='$attrName' id='$weightKey'\n" if $VERBOSE;
|
1467
|
|
|
|
|
|
|
if (my $defaultNode = $xpc->findnodes('.//gml:default[1]',$keyEdge)->[0]) {
|
1468
|
|
|
|
|
|
|
$defaultWeight = $defaultNode->textContent();
|
1469
|
|
|
|
|
|
|
}
|
1470
|
|
|
|
|
|
|
last;
|
1471
|
|
|
|
|
|
|
}
|
1472
|
|
|
|
|
|
|
}
|
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
if (!$weightKey) {
|
1475
|
|
|
|
|
|
|
croak "inputGraphfromGraphML: graph does not contain key attribute for edge weight/value/cost/distance ''. Not supported.";
|
1476
|
|
|
|
|
|
|
}
|
1477
|
|
|
|
|
|
|
}
|
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
if ($edgeLabelKey) {
|
1480
|
|
|
|
|
|
|
if (my $keyEdgeLabelNode = $xpc->findnodes("/gml:graphml/gml:key[\@for=\"edge\" and \@id=\"$edgeLabelKey\"]")->[0]) {
|
1481
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found edgeKeyLabelID '$edgeLabelKey' in GraphML key elements list\n" if $VERBOSE;
|
1482
|
|
|
|
|
|
|
}
|
1483
|
|
|
|
|
|
|
else {
|
1484
|
|
|
|
|
|
|
# carp "inputGraphfromGraphML: edgeKeyLabelID '$edgeLabelKey' not found in GraphML key elements list";
|
1485
|
|
|
|
|
|
|
$edgeLabelKey = $EMPTY_STRING;
|
1486
|
|
|
|
|
|
|
}
|
1487
|
|
|
|
|
|
|
}
|
1488
|
|
|
|
|
|
|
my $edgeLabelXPATH = ($edgeLabelKey) ? ".//gml:data[\@key=\"$edgeLabelKey\"]" : $EMPTY_STRING;
|
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
my $labelXPATH = $EMPTY_STRING;
|
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
if ($labelKey) {
|
1493
|
|
|
|
|
|
|
if (my $keyNodeLabelNode = $xpc->findnodes("/gml:graphml/gml:key[\@for=\"node\" and \@id=\"$labelKey\"]")->[0]) {
|
1494
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found nodeLabelValueID '$labelKey' in GraphML key elements list\n" if $VERBOSE;
|
1495
|
|
|
|
|
|
|
}
|
1496
|
|
|
|
|
|
|
else {
|
1497
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: nodeLabelValueID '$labelKey' not found in GraphML key elements list";
|
1498
|
|
|
|
|
|
|
$labelKey = $EMPTY_STRING;
|
1499
|
|
|
|
|
|
|
}
|
1500
|
|
|
|
|
|
|
}
|
1501
|
|
|
|
|
|
|
|
1502
|
|
|
|
|
|
|
if (!$labelKey) {
|
1503
|
|
|
|
|
|
|
foreach my $keyNode ($xpc->findnodes('/gml:graphml/gml:key[@for="node" and @attr.type="string"]')) {
|
1504
|
|
|
|
|
|
|
my $attrName = $keyNode->getAttribute('attr.name') || $EMPTY_STRING;
|
1505
|
|
|
|
|
|
|
if ($IS_GRAPHML_LABEL_ATTR{lc($attrName)}) {
|
1506
|
|
|
|
|
|
|
$labelKey = $keyNode->getAttribute('id');
|
1507
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found key attribute for node 'label' attr.name='$attrName' id='$labelKey'\n" if $VERBOSE;
|
1508
|
|
|
|
|
|
|
last;
|
1509
|
|
|
|
|
|
|
}
|
1510
|
|
|
|
|
|
|
}
|
1511
|
|
|
|
|
|
|
}
|
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
if (!$labelKey) {
|
1514
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: key node name / label / description attribute not found in graphml";
|
1515
|
|
|
|
|
|
|
}
|
1516
|
|
|
|
|
|
|
else {
|
1517
|
|
|
|
|
|
|
$labelXPATH = ".//gml:data[\@key=\"$labelKey\"]";
|
1518
|
|
|
|
|
|
|
}
|
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
if (my $keyGraphCreator = $xpc->findnodes("/gml:graphml/gml:key[\@for=\"graph\" and \@id=\"creator\"]")->[0]) {
|
1521
|
|
|
|
|
|
|
if (my $dataGraphCreator = $xpc->findnodes("/gml:graphml/gml:graph/gml:data[\@key=\"creator\"]")->[0]) {
|
1522
|
|
|
|
|
|
|
if (my $creator = $dataGraphCreator->textContent()) {
|
1523
|
|
|
|
|
|
|
$self->graph( {creator=>$creator} );
|
1524
|
|
|
|
|
|
|
}
|
1525
|
|
|
|
|
|
|
}
|
1526
|
|
|
|
|
|
|
}
|
1527
|
|
|
|
|
|
|
if (my $keyGraphLabel = $xpc->findnodes("/gml:graphml/gml:key[\@for=\"graph\" and \@id=\"graphlabel\"]")->[0]) {
|
1528
|
|
|
|
|
|
|
if (my $dataGraphLabel = $xpc->findnodes("/gml:graphml/gml:graph/gml:data[\@key=\"graphlabel\"]")->[0]) {
|
1529
|
|
|
|
|
|
|
if (my $label = $dataGraphLabel->textContent()) {
|
1530
|
|
|
|
|
|
|
$self->graph( {label=>$label} );
|
1531
|
|
|
|
|
|
|
}
|
1532
|
|
|
|
|
|
|
}
|
1533
|
|
|
|
|
|
|
}
|
1534
|
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
|
foreach my $nodeElement ($xpc->findnodes('/gml:graphml/gml:graph/gml:node')) {
|
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
my $node = $nodeElement->nodeName();
|
1538
|
|
|
|
|
|
|
my $id = $nodeElement->getAttribute('id');
|
1539
|
|
|
|
|
|
|
my $label = $EMPTY_STRING;
|
1540
|
|
|
|
|
|
|
if ($labelXPATH and my $dataNameNode = $xpc->findnodes($labelXPATH,$nodeElement)->[0]) {
|
1541
|
|
|
|
|
|
|
$label = $dataNameNode->textContent();
|
1542
|
|
|
|
|
|
|
}
|
1543
|
|
|
|
|
|
|
$dupnodecount++ if $self->nodeExists($id);
|
1544
|
|
|
|
|
|
|
$self->node( {id=>$id,label=>$label } );
|
1545
|
|
|
|
|
|
|
$nodecount++;
|
1546
|
|
|
|
|
|
|
}
|
1547
|
|
|
|
|
|
|
|
1548
|
|
|
|
|
|
|
my $weightXPATH = ".//gml:data[\@key=\"$weightKey\"]";
|
1549
|
|
|
|
|
|
|
|
1550
|
|
|
|
|
|
|
foreach my $edgeElement ($xpc->findnodes('/gml:graphml/gml:graph/gml:edge')) {
|
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
my $edge = $edgeElement->nodeName();
|
1553
|
|
|
|
|
|
|
my $source = $edgeElement->getAttribute('source');
|
1554
|
|
|
|
|
|
|
my $target = $edgeElement->getAttribute('target');
|
1555
|
|
|
|
|
|
|
my $edgeID = ($edgeElement->hasAttribute('id')) ? $edgeElement->getAttribute('id') : $EMPTY_STRING;
|
1556
|
|
|
|
|
|
|
my $edgeDirected = ($edgeElement->hasAttribute('directed')) ? $edgeElement->getAttribute('directed') : $graphDirected;
|
1557
|
|
|
|
|
|
|
my $edgeLabel = '';
|
1558
|
|
|
|
|
|
|
if ($edgeLabelXPATH and my $dataEdgeLabelNode = $xpc->findnodes($edgeLabelXPATH,$edgeElement)->[0]) {
|
1559
|
|
|
|
|
|
|
$edgeLabel = $dataEdgeLabelNode->textContent();
|
1560
|
|
|
|
|
|
|
}
|
1561
|
|
|
|
|
|
|
my $weight = $defaultWeight;
|
1562
|
|
|
|
|
|
|
if (my $dataWeightNode = $xpc->findnodes($weightXPATH,$edgeElement)->[0]) {
|
1563
|
|
|
|
|
|
|
$weight = $dataWeightNode->textContent();
|
1564
|
|
|
|
|
|
|
}
|
1565
|
|
|
|
|
|
|
if ($weight) {
|
1566
|
|
|
|
|
|
|
$dupedgecount++ if $self->edgeExists( { sourceID=>$source, targetID=>$target } );
|
1567
|
|
|
|
|
|
|
my %edgeAttribs = (sourceID=>$source, targetID=>$target, weight=>$weight, directed=>$edgeDirected);
|
1568
|
|
|
|
|
|
|
$edgeAttribs{id} = $edgeID if $edgeID;
|
1569
|
|
|
|
|
|
|
$edgeAttribs{label} = $edgeLabel if $edgeLabel;
|
1570
|
|
|
|
|
|
|
|
1571
|
|
|
|
|
|
|
if (defined($self->edge( \%edgeAttribs ) )) {
|
1572
|
|
|
|
|
|
|
$edgecount++;
|
1573
|
|
|
|
|
|
|
}
|
1574
|
|
|
|
|
|
|
else {
|
1575
|
|
|
|
|
|
|
$badedgecount++;
|
1576
|
|
|
|
|
|
|
}
|
1577
|
|
|
|
|
|
|
}
|
1578
|
|
|
|
|
|
|
else {
|
1579
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: edge $source $target has no weight. Not created."
|
1580
|
|
|
|
|
|
|
}
|
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
}
|
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: no nodes read from '$filename'" if !$nodecount;
|
1585
|
|
|
|
|
|
|
carp "inputGraphfromGraphML: no edges read from '$filename'" if !$edgecount;
|
1586
|
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
1588
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found $dupnodecount duplicate nodes\n" if $dupnodecount and $VERBOSE;
|
1589
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: found $dupedgecount duplicate edges\n" if $dupedgecount and $VERBOSE;
|
1590
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGraphML: $badedgecount edges rejected (bad)\n" if $badedgecount and $VERBOSE;
|
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
return $self;
|
1593
|
|
|
|
|
|
|
}
|
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
|
sub outputGraphtoGraphML {
|
1597
|
|
|
|
|
|
|
my ($self, $filename, $options) = @_;
|
1598
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
my $nsURI = "http://graphml.graphdrawing.org/xmlns";
|
1600
|
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
my $doc = XML::LibXML::Document->new('1.0','UTF-8');
|
1602
|
|
|
|
|
|
|
my $graphML = $doc->createElementNS( $EMPTY_STRING, 'graphml' );
|
1603
|
|
|
|
|
|
|
$doc->setDocumentElement( $graphML );
|
1604
|
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
|
$graphML->setNamespace( $nsURI , $EMPTY_STRING, 1 );
|
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
{
|
1608
|
|
|
|
|
|
|
my $now_string = localtime;
|
1609
|
|
|
|
|
|
|
$graphML->appendChild($doc->createComment("Generated by Graph::Dijkstra on $now_string"));
|
1610
|
|
|
|
|
|
|
}
|
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
$graphML->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance');
|
1613
|
|
|
|
|
|
|
$graphML->setAttribute('xsi:schemaLocation','http://graphml.graphdrawing.org/xmlns http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd');
|
1614
|
|
|
|
|
|
|
|
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
my $keyEdgeWeightID = $options->{keyEdgeWeightID} || 'weight';
|
1618
|
|
|
|
|
|
|
my $keyEdgeWeightAttrName = $options->{keyEdgeWeightAttrName} || 'weight';
|
1619
|
|
|
|
|
|
|
my $keyNodeLabelID = $options->{keyNodeLabelID} || 'name';
|
1620
|
|
|
|
|
|
|
my $keyNodeLabelAttrName = $options->{keyNodeLabelAttrName} || 'name';
|
1621
|
|
|
|
|
|
|
my $keyEdgeLabelID = $options->{keyEdgeLabelID} || 'label';
|
1622
|
|
|
|
|
|
|
my $keyEdgeLabelAttrName = $options->{keyEdgeLabelAttrName} || 'label';
|
1623
|
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
|
my $keyNode = $graphML->addNewChild( $nsURI, 'key' );
|
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
$keyNode->setAttribute('for','node');
|
1627
|
|
|
|
|
|
|
$keyNode->setAttribute('id', $keyNodeLabelID );
|
1628
|
|
|
|
|
|
|
$keyNode->setAttribute('attr.name', $keyNodeLabelAttrName );
|
1629
|
|
|
|
|
|
|
$keyNode->setAttribute('attr.type', 'string' );
|
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
my $keyEdge = $graphML->addNewChild( $nsURI, 'key' );
|
1632
|
|
|
|
|
|
|
$keyEdge->setAttribute('for','edge');
|
1633
|
|
|
|
|
|
|
$keyEdge->setAttribute('id', $keyEdgeWeightID );
|
1634
|
|
|
|
|
|
|
$keyEdge->setAttribute('attr.name', $keyEdgeWeightAttrName );
|
1635
|
|
|
|
|
|
|
$keyEdge->setAttribute('attr.type', 'double' );
|
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
$keyEdge = $graphML->addNewChild( $nsURI, 'key' );
|
1638
|
|
|
|
|
|
|
$keyEdge->setAttribute('for','edge');
|
1639
|
|
|
|
|
|
|
$keyEdge->setAttribute('id', $keyEdgeLabelID );
|
1640
|
|
|
|
|
|
|
$keyEdge->setAttribute('attr.name', $keyEdgeLabelAttrName );
|
1641
|
|
|
|
|
|
|
$keyEdge->setAttribute('attr.type', 'string' );
|
1642
|
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
|
if ($self->{creator}) {
|
1644
|
|
|
|
|
|
|
my $keyGraph = $graphML->addNewChild( $nsURI, 'key' );
|
1645
|
|
|
|
|
|
|
$keyGraph->setAttribute('for','graph');
|
1646
|
|
|
|
|
|
|
$keyGraph->setAttribute('id','creator');
|
1647
|
|
|
|
|
|
|
$keyGraph->setAttribute('attr.name','creator');
|
1648
|
|
|
|
|
|
|
$keyGraph->setAttribute('attr.type','string');
|
1649
|
|
|
|
|
|
|
}
|
1650
|
|
|
|
|
|
|
if ($self->{label}) {
|
1651
|
|
|
|
|
|
|
my $keyGraph = $graphML->addNewChild( $nsURI, 'key' );
|
1652
|
|
|
|
|
|
|
$keyGraph->setAttribute('for','graph');
|
1653
|
|
|
|
|
|
|
$keyGraph->setAttribute('id','graphlabel');
|
1654
|
|
|
|
|
|
|
$keyGraph->setAttribute('attr.name','label');
|
1655
|
|
|
|
|
|
|
$keyGraph->setAttribute('attr.type','string');
|
1656
|
|
|
|
|
|
|
}
|
1657
|
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
|
my $graph = $graphML->addNewChild( $nsURI, 'graph' );
|
1659
|
|
|
|
|
|
|
$graph->setAttribute('id','G');
|
1660
|
|
|
|
|
|
|
$graph->setAttribute('edgedefault', $self->{edgedefault} );
|
1661
|
|
|
|
|
|
|
if ($self->{creator}) {
|
1662
|
|
|
|
|
|
|
my $dataNode = $graph->addNewChild( $nsURI, 'data');
|
1663
|
|
|
|
|
|
|
$dataNode->setAttribute('key', 'creator');
|
1664
|
|
|
|
|
|
|
$dataNode->appendTextNode( $self->{creator} );
|
1665
|
|
|
|
|
|
|
}
|
1666
|
|
|
|
|
|
|
if ($self->{label}) {
|
1667
|
|
|
|
|
|
|
my $dataNode = $graph->addNewChild( $nsURI, 'data');
|
1668
|
|
|
|
|
|
|
$dataNode->setAttribute('key', 'label');
|
1669
|
|
|
|
|
|
|
$dataNode->appendTextNode( $self->{label} );
|
1670
|
|
|
|
|
|
|
}
|
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
my $nodecount = 0;
|
1673
|
|
|
|
|
|
|
my $edgecount = 0;
|
1674
|
|
|
|
|
|
|
|
1675
|
|
|
|
|
|
|
my %edges = ();
|
1676
|
|
|
|
|
|
|
foreach my $nodeID (keys %{$self->{graph}}) {
|
1677
|
|
|
|
|
|
|
|
1678
|
|
|
|
|
|
|
my $nodeNode = $graph->addNewChild( $nsURI, 'node' );
|
1679
|
|
|
|
|
|
|
$nodeNode->setAttribute('id', $nodeID);
|
1680
|
|
|
|
|
|
|
my $dataNode = $nodeNode->addNewChild( $nsURI, 'data');
|
1681
|
|
|
|
|
|
|
$dataNode->setAttribute('key', $keyNodeLabelID);
|
1682
|
|
|
|
|
|
|
$dataNode->appendTextNode( $self->{graph}{$nodeID}{label} );
|
1683
|
|
|
|
|
|
|
|
1684
|
|
|
|
|
|
|
$nodecount++;
|
1685
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
1686
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
1687
|
|
|
|
|
|
|
my $directed = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
1688
|
|
|
|
|
|
|
if ( ($directed eq 'undirected' and !exists($edges{$targetID}{$nodeID})) or $directed eq 'directed') {
|
1689
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
1690
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{id} = $self->{graph}{$nodeID}{edges}{$targetID}{id};
|
1691
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{directed} = $directed;
|
1692
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{label} = $self->{graph}{$nodeID}{edges}{$targetID}{label};
|
1693
|
|
|
|
|
|
|
}
|
1694
|
|
|
|
|
|
|
}
|
1695
|
|
|
|
|
|
|
}
|
1696
|
|
|
|
|
|
|
}
|
1697
|
|
|
|
|
|
|
foreach my $sourceID (keys %edges) {
|
1698
|
|
|
|
|
|
|
foreach my $targetID (keys %{$edges{$sourceID}}) {
|
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
$edgecount++;
|
1701
|
|
|
|
|
|
|
my $edgeNode = $graph->addNewChild( $nsURI, 'edge');
|
1702
|
|
|
|
|
|
|
$edgeNode->setAttribute('id', ($edges{$sourceID}{$targetID}{id} ne $EMPTY_STRING) ? $edges{$sourceID}{$targetID}{id} : $edgecount);
|
1703
|
|
|
|
|
|
|
$edgeNode->setAttribute('source', $sourceID );
|
1704
|
|
|
|
|
|
|
$edgeNode->setAttribute('target', $targetID );
|
1705
|
|
|
|
|
|
|
$edgeNode->setAttribute('directed', $edges{$sourceID}{$targetID}{directed} ) if $edges{$sourceID}{$targetID}{directed} ne $self->{edgedefault};
|
1706
|
|
|
|
|
|
|
my $dataNode = $edgeNode->addNewChild( $nsURI, 'data');
|
1707
|
|
|
|
|
|
|
$dataNode->setAttribute('key', $keyEdgeWeightID );
|
1708
|
|
|
|
|
|
|
$dataNode->appendTextNode( $edges{$sourceID}{$targetID}{weight} );
|
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
if ( $edges{$sourceID}{$targetID}{label} ) {
|
1711
|
|
|
|
|
|
|
$dataNode = $edgeNode->addNewChild( $nsURI, 'data');
|
1712
|
|
|
|
|
|
|
$dataNode->setAttribute('key', $keyEdgeLabelID );
|
1713
|
|
|
|
|
|
|
$dataNode->appendTextNode( $edges{$sourceID}{$targetID}{label} );
|
1714
|
|
|
|
|
|
|
}
|
1715
|
|
|
|
|
|
|
}
|
1716
|
|
|
|
|
|
|
}
|
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
my $state = $doc->toFile($filename,2);
|
1719
|
|
|
|
|
|
|
croak "could not output internal grap to '$filename'" if !$state;
|
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoGraphML: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
1722
|
|
|
|
|
|
|
return $self;
|
1723
|
|
|
|
|
|
|
}
|
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
|
1726
|
|
|
|
|
|
|
sub inputGraphfromGEXF { ## no critic (ProhibitExcessComplexity)
|
1727
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
if (!ref($self)) {
|
1730
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
1731
|
|
|
|
|
|
|
}
|
1732
|
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
my $dom = XML::LibXML->load_xml(location => $filename);
|
1734
|
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: input '$filename'\n" if $VERBOSE;
|
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
my $topNode = $dom->nonBlankChildNodes()->[0];
|
1738
|
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: not a GEXF format XML file" if lc($topNode->nodeName()) ne 'gexf';
|
1740
|
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
|
my $nsURI = $topNode->getAttribute('xmlns') || '';
|
1742
|
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: not a GEXF draft specification 1.1 or 1.2 format XML file" if ( $nsURI !~ /^http:\/\/www.gexf.net\/1\.[1-2]draft$/i );
|
1744
|
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
|
my $gexfVersion = $topNode->getAttribute('version') || ''; #don't do anything with the GEXF version string
|
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
my $xpc = XML::LibXML::XPathContext->new($dom);
|
1748
|
|
|
|
|
|
|
$xpc->registerNs('gexf', $nsURI);
|
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
my $nodecount = 0;
|
1751
|
|
|
|
|
|
|
my $edgecount = 0;
|
1752
|
|
|
|
|
|
|
my $dupedgecount = 0;
|
1753
|
|
|
|
|
|
|
my $defaultWeight = 1;
|
1754
|
|
|
|
|
|
|
my $graphDirected = 'undirected';
|
1755
|
|
|
|
|
|
|
my $attvalueWeightCount = 0;
|
1756
|
|
|
|
|
|
|
my $weightXPATH = ".//gexf:attvalues/gexf:attvalue[\@for=\"weight\"]";
|
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
if (my $graphNode = $xpc->findnodes('/gexf:gexf/gexf:graph')->[0] ) {
|
1759
|
|
|
|
|
|
|
$graphDirected = ($graphNode->hasAttribute('defaultedgetype')) ? lc($graphNode->getAttribute('defaultedgetype')) : 'undirected';
|
1760
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: graph defaultedgetype is 'mutual'. Not supported." if $graphDirected eq 'mutual';
|
1761
|
|
|
|
|
|
|
$self->graph( {edgedefault=>$graphDirected} );
|
1762
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: graph edgedefault is '$graphDirected'.\n" if $VERBOSE;
|
1763
|
|
|
|
|
|
|
my $mode = $graphNode->getAttribute('mode') || $EMPTY_STRING;
|
1764
|
|
|
|
|
|
|
carp "inputGraphfromGEXF: graph mode is 'dynamic'. Ignored." if lc($mode) eq 'dynamic';
|
1765
|
|
|
|
|
|
|
}
|
1766
|
|
|
|
|
|
|
else {
|
1767
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: GEXF file has no element";
|
1768
|
|
|
|
|
|
|
}
|
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
if (my $graphNode = $xpc->findnodes('/gexf:gexf/gexf:graph[2]')->[0] ) {
|
1771
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: file contains more than one graph. Not supported.";
|
1772
|
|
|
|
|
|
|
}
|
1773
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
if (my $heirarchyNode = $xpc->findnodes('/gexf:gexf/gexf:graph/gexf:nodes/gexf:node/gexf:nodes')->[0] ) {
|
1775
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: file contains heirarchical nodes. Not supported.";
|
1776
|
|
|
|
|
|
|
}
|
1777
|
|
|
|
|
|
|
if (my $parentsNode = $xpc->findnodes('/gexf:gexf/gexf:graph/gexf:nodes/gexf:node/gexf:parents')->[0] ) {
|
1778
|
|
|
|
|
|
|
croak "inputGraphfromGEXF: file contains parent nodes. Not supported.";
|
1779
|
|
|
|
|
|
|
}
|
1780
|
|
|
|
|
|
|
|
1781
|
|
|
|
|
|
|
if (my $metaNode = $xpc->findnodes('/gexf:gexf/gexf:meta/gexf:creator')->[0] ) {
|
1782
|
|
|
|
|
|
|
if (my $creator = $metaNode->textContent()) {
|
1783
|
|
|
|
|
|
|
$self->graph( { creator=>$creator } );
|
1784
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: set graph attribute creator: $creator\n" if $VERBOSE;
|
1785
|
|
|
|
|
|
|
}
|
1786
|
|
|
|
|
|
|
}
|
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
if (my $metaNode = $xpc->findnodes('/gexf:gexf/gexf:meta/gexf:description')->[0] ) {
|
1789
|
|
|
|
|
|
|
if (my $label = $metaNode->textContent()) {
|
1790
|
|
|
|
|
|
|
$self->graph( { label=>$label } );
|
1791
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: set graph attribute label (from meta attribute description): $label\n" if $VERBOSE;
|
1792
|
|
|
|
|
|
|
}
|
1793
|
|
|
|
|
|
|
}
|
1794
|
|
|
|
|
|
|
|
1795
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
foreach my $nodeElement ($xpc->findnodes('/gexf:gexf/gexf:graph/gexf:nodes/gexf:node')) {
|
1797
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
#my $node = $nodeElement->nodeName();
|
1799
|
|
|
|
|
|
|
my $id = $nodeElement->getAttribute('id');
|
1800
|
|
|
|
|
|
|
my $label = $nodeElement->getAttribute('label') || $EMPTY_STRING;
|
1801
|
|
|
|
|
|
|
$self->node( {id=>$id, label=>$label} );
|
1802
|
|
|
|
|
|
|
$nodecount++;
|
1803
|
|
|
|
|
|
|
}
|
1804
|
|
|
|
|
|
|
|
1805
|
|
|
|
|
|
|
foreach my $edgeElement ($xpc->findnodes('/gexf:gexf/gexf:graph/gexf:edges/gexf:edge')) {
|
1806
|
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
|
#my $edge = $edgeElement->nodeName();
|
1808
|
|
|
|
|
|
|
my $source = $edgeElement->getAttribute('source'); #source, target, and id are required attributes
|
1809
|
|
|
|
|
|
|
my $target = $edgeElement->getAttribute('target');
|
1810
|
|
|
|
|
|
|
my $edgeID = $edgeElement->getAttribute('id');
|
1811
|
|
|
|
|
|
|
my $weight = $defaultWeight;
|
1812
|
|
|
|
|
|
|
if ($edgeElement->hasAttribute('weight')) {
|
1813
|
|
|
|
|
|
|
$weight = $edgeElement->getAttribute('weight');
|
1814
|
|
|
|
|
|
|
}
|
1815
|
|
|
|
|
|
|
elsif (my $dataWeightNode = $xpc->findnodes($weightXPATH,$edgeElement)->[0]) {
|
1816
|
|
|
|
|
|
|
$weight = $dataWeightNode->getAttribute('value');
|
1817
|
|
|
|
|
|
|
$attvalueWeightCount++;
|
1818
|
|
|
|
|
|
|
}
|
1819
|
|
|
|
|
|
|
my $label = ($edgeElement->hasAttribute('label')) ? $edgeElement->getAttribute('label') : $EMPTY_STRING;
|
1820
|
|
|
|
|
|
|
my $edgeDirected = ($edgeElement->hasAttribute('type')) ? $edgeElement->getAttribute('type') : $graphDirected;
|
1821
|
|
|
|
|
|
|
if ($weight) {
|
1822
|
|
|
|
|
|
|
$dupedgecount++ if $self->edgeExists( { sourceID=>$source, targetID=>$target } );
|
1823
|
|
|
|
|
|
|
$self->edge( { sourceID=>$source, targetID=>$target, weight=>$weight, directed=>$edgeDirected, label=>$label, id=>$edgeID } );
|
1824
|
|
|
|
|
|
|
$edgecount++;
|
1825
|
|
|
|
|
|
|
}
|
1826
|
|
|
|
|
|
|
else {
|
1827
|
|
|
|
|
|
|
carp "inputGraphfromGEXF: edge $source $target has no weight. Not created."
|
1828
|
|
|
|
|
|
|
}
|
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
}
|
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
carp "inputGraphfromGEXF: no nodes read from '$filename'" if !$nodecount;
|
1833
|
|
|
|
|
|
|
carp "inputGraphfromGEXF: no edges read from '$filename'" if !$edgecount;
|
1834
|
|
|
|
|
|
|
|
1835
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
1836
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: found $dupedgecount duplicate edges\n" if $dupedgecount and $VERBOSE;
|
1837
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromGEXF: input edge weight from attvalue element for $attvalueWeightCount edges\n" if $attvalueWeightCount and $VERBOSE;
|
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
return $self;
|
1840
|
|
|
|
|
|
|
}
|
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
|
1843
|
|
|
|
|
|
|
sub outputGraphtoGEXF {
|
1844
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
my $nsURI = 'http://www.gexf.net/1.2draft';
|
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
my $doc = XML::LibXML::Document->new('1.0','UTF-8');
|
1849
|
|
|
|
|
|
|
my $GEXF = $doc->createElementNS( $EMPTY_STRING, 'gexf' );
|
1850
|
|
|
|
|
|
|
$doc->setDocumentElement( $GEXF );
|
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
$GEXF->setNamespace( $nsURI , $EMPTY_STRING, 1 );
|
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
$GEXF->setAttribute('xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance');
|
1855
|
|
|
|
|
|
|
$GEXF->setAttribute('xsi:schemaLocation','http://www.gexf.net/1.2draft http://www.gexf.net/1.2draft/gexf.xsd');
|
1856
|
|
|
|
|
|
|
$GEXF->setAttribute('version','1.2');
|
1857
|
|
|
|
|
|
|
|
1858
|
|
|
|
|
|
|
{
|
1859
|
|
|
|
|
|
|
my $now_string = localtime;
|
1860
|
|
|
|
|
|
|
$GEXF->appendChild($doc->createComment("Generated by Graph::Dijkstra on $now_string"));
|
1861
|
|
|
|
|
|
|
}
|
1862
|
|
|
|
|
|
|
{
|
1863
|
|
|
|
|
|
|
my (undef, undef, undef, $mday, $month, $year, undef, undef, undef) = localtime;
|
1864
|
|
|
|
|
|
|
my $ISODATE = sprintf "%4d-%02d-%02d", $year+1900, $month+1, $mday;
|
1865
|
|
|
|
|
|
|
my $meta = $GEXF->addNewChild( $nsURI, 'meta');
|
1866
|
|
|
|
|
|
|
$meta->setAttribute('lastmodifieddate', $ISODATE);
|
1867
|
|
|
|
|
|
|
if ($self->{creator}) {
|
1868
|
|
|
|
|
|
|
my $creatorNode = $meta->addNewChild( $nsURI, 'creator');
|
1869
|
|
|
|
|
|
|
$creatorNode->appendTextNode( $self->{creator} );
|
1870
|
|
|
|
|
|
|
}
|
1871
|
|
|
|
|
|
|
if ($self->{label}) {
|
1872
|
|
|
|
|
|
|
my $descriptionNode = $meta->addNewChild( $nsURI, 'description');
|
1873
|
|
|
|
|
|
|
$descriptionNode->appendTextNode( $self->{label} );
|
1874
|
|
|
|
|
|
|
}
|
1875
|
|
|
|
|
|
|
}
|
1876
|
|
|
|
|
|
|
|
1877
|
|
|
|
|
|
|
my $graph = $GEXF->addNewChild( $nsURI, 'graph' );
|
1878
|
|
|
|
|
|
|
$graph->setAttribute('mode','static');
|
1879
|
|
|
|
|
|
|
$graph->setAttribute('defaultedgetype', $self->{edgedefault} );
|
1880
|
|
|
|
|
|
|
my $nodesElement = $graph->addNewChild( $nsURI, 'nodes' );
|
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
my $nodecount = 0;
|
1883
|
|
|
|
|
|
|
my $edgecount = 0;
|
1884
|
|
|
|
|
|
|
|
1885
|
|
|
|
|
|
|
my %edges = ();
|
1886
|
|
|
|
|
|
|
foreach my $nodeID (keys %{$self->{graph}}) {
|
1887
|
|
|
|
|
|
|
|
1888
|
|
|
|
|
|
|
my $nodeNode = $nodesElement->addNewChild( $nsURI, 'node' );
|
1889
|
|
|
|
|
|
|
$nodeNode->setAttribute('id', $nodeID);
|
1890
|
|
|
|
|
|
|
$nodeNode->setAttribute('label', $self->{graph}{$nodeID}{label} );
|
1891
|
|
|
|
|
|
|
|
1892
|
|
|
|
|
|
|
$nodecount++;
|
1893
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
1894
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
1895
|
|
|
|
|
|
|
my $directed = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
1896
|
|
|
|
|
|
|
if ( ($directed eq 'undirected' and !exists($edges{$targetID}{$nodeID})) or $directed eq 'directed') {
|
1897
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
1898
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{id} = $self->{graph}{$nodeID}{edges}{$targetID}{id};
|
1899
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{directed} = $directed;
|
1900
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{label} = $self->{graph}{$nodeID}{edges}{$targetID}{label};
|
1901
|
|
|
|
|
|
|
}
|
1902
|
|
|
|
|
|
|
}
|
1903
|
|
|
|
|
|
|
}
|
1904
|
|
|
|
|
|
|
}
|
1905
|
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
|
my $edgesElement = $graph->addNewChild( $nsURI, 'edges' );
|
1907
|
|
|
|
|
|
|
|
1908
|
|
|
|
|
|
|
foreach my $sourceID (keys %edges) {
|
1909
|
|
|
|
|
|
|
foreach my $targetID (keys %{$edges{$sourceID}}) {
|
1910
|
|
|
|
|
|
|
|
1911
|
|
|
|
|
|
|
$edgecount++;
|
1912
|
|
|
|
|
|
|
my $edgeNode = $edgesElement->addNewChild( $nsURI, 'edge');
|
1913
|
|
|
|
|
|
|
$edgeNode->setAttribute('id', ($edges{$sourceID}{$targetID}{id} ne '') ? $edges{$sourceID}{$targetID}{id} : $edgecount);
|
1914
|
|
|
|
|
|
|
$edgeNode->setAttribute('source', $sourceID );
|
1915
|
|
|
|
|
|
|
$edgeNode->setAttribute('target', $targetID );
|
1916
|
|
|
|
|
|
|
$edgeNode->setAttribute('weight', $edges{$sourceID}{$targetID}{weight} );
|
1917
|
|
|
|
|
|
|
$edgeNode->setAttribute('directed', $edges{$sourceID}{$targetID}{directed} ) if $edges{$sourceID}{$targetID}{directed} ne $self->{edgedefault};
|
1918
|
|
|
|
|
|
|
$edgeNode->setAttribute('label', $edges{$sourceID}{$targetID}{label} ) if $edges{$sourceID}{$targetID}{label};
|
1919
|
|
|
|
|
|
|
|
1920
|
|
|
|
|
|
|
}
|
1921
|
|
|
|
|
|
|
}
|
1922
|
|
|
|
|
|
|
my $state = $doc->toFile($filename,2);
|
1923
|
|
|
|
|
|
|
croak "could not output internal grap to '$filename'" if !$state;
|
1924
|
|
|
|
|
|
|
|
1925
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoGEXF: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
1926
|
|
|
|
|
|
|
return $self;
|
1927
|
|
|
|
|
|
|
}
|
1928
|
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
|
sub validateGraphMLxml {
|
1930
|
|
|
|
|
|
|
my ($either, $filename) = @_;
|
1931
|
|
|
|
|
|
|
|
1932
|
|
|
|
|
|
|
Readonly my $GraphML_URL => 'http://graphml.graphdrawing.org/xmlns/1.1/graphml.xsd';
|
1933
|
|
|
|
|
|
|
|
1934
|
|
|
|
|
|
|
my $GraphMLschema;
|
1935
|
|
|
|
|
|
|
|
1936
|
|
|
|
|
|
|
eval {
|
1937
|
|
|
|
|
|
|
$GraphMLschema = XML::LibXML::Schema->new( location => $GraphML_URL );
|
1938
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGraphMLxml: loaded GraphML schema\n" if $VERBOSE;
|
1939
|
|
|
|
|
|
|
};
|
1940
|
|
|
|
|
|
|
if ($@) {
|
1941
|
|
|
|
|
|
|
print {$verboseOutfile} "\n$@\n" if $VERBOSE;
|
1942
|
|
|
|
|
|
|
carp "validateGraphMLxml: GraphML xml schema URL not accessible: $GraphML_URL";
|
1943
|
|
|
|
|
|
|
return(0,'GraphML xml schema URL not accessible');
|
1944
|
|
|
|
|
|
|
}
|
1945
|
|
|
|
|
|
|
|
1946
|
|
|
|
|
|
|
my $dom = XML::LibXML->load_xml(location => $filename);
|
1947
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGraphMLxml: loaded '$filename'\n" if $VERBOSE;
|
1948
|
|
|
|
|
|
|
|
1949
|
|
|
|
|
|
|
eval { $GraphMLschema->validate( $dom ); };
|
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
if ($@) {
|
1952
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGraphMLxml: validate failed\n$@\n" if $VERBOSE;
|
1953
|
|
|
|
|
|
|
return(0,$@);
|
1954
|
|
|
|
|
|
|
}
|
1955
|
|
|
|
|
|
|
else {
|
1956
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGraphMLxml: validated\n" if $VERBOSE;
|
1957
|
|
|
|
|
|
|
return(1,$EMPTY_STRING);
|
1958
|
|
|
|
|
|
|
}
|
1959
|
|
|
|
|
|
|
|
1960
|
|
|
|
|
|
|
}
|
1961
|
|
|
|
|
|
|
|
1962
|
|
|
|
|
|
|
sub validateGEXFxml {
|
1963
|
|
|
|
|
|
|
my ($either, $filename) = @_;
|
1964
|
|
|
|
|
|
|
|
1965
|
|
|
|
|
|
|
Readonly my $GEXF_URL => 'http://www.gexf.net/1.2draft/gexf.xsd';
|
1966
|
|
|
|
|
|
|
my $GEXFschema;
|
1967
|
|
|
|
|
|
|
|
1968
|
|
|
|
|
|
|
eval {
|
1969
|
|
|
|
|
|
|
$GEXFschema = XML::LibXML::Schema->new( location => $GEXF_URL );
|
1970
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGEXFxml: loaded GEXF schema\n" if $VERBOSE;
|
1971
|
|
|
|
|
|
|
};
|
1972
|
|
|
|
|
|
|
if ($@) {
|
1973
|
|
|
|
|
|
|
print {$verboseOutfile} "\n$@\n" if $VERBOSE;
|
1974
|
|
|
|
|
|
|
carp "validateGEXFxml: GEXF xml schema URL not accessible: $GEXF_URL";
|
1975
|
|
|
|
|
|
|
return(0,'GEXF xml schema URL not accessible');
|
1976
|
|
|
|
|
|
|
}
|
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
my $dom = XML::LibXML->load_xml(location => $filename);
|
1979
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGEXFxml: loaded '$filename'\n" if $VERBOSE;
|
1980
|
|
|
|
|
|
|
|
1981
|
|
|
|
|
|
|
eval { $GEXFschema->validate( $dom ); };
|
1982
|
|
|
|
|
|
|
|
1983
|
|
|
|
|
|
|
if ($@) {
|
1984
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGEXFxml: validate failed\n$@\n" if $VERBOSE;
|
1985
|
|
|
|
|
|
|
return(0,$@);
|
1986
|
|
|
|
|
|
|
}
|
1987
|
|
|
|
|
|
|
else {
|
1988
|
|
|
|
|
|
|
print {$verboseOutfile} "validateGEXFxml: validated\n" if $VERBOSE;
|
1989
|
|
|
|
|
|
|
return(1,$EMPTY_STRING);
|
1990
|
|
|
|
|
|
|
}
|
1991
|
|
|
|
|
|
|
|
1992
|
|
|
|
|
|
|
}
|
1993
|
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
|
1995
|
|
|
|
|
|
|
} #XML file format methods
|
1996
|
|
|
|
|
|
|
|
1997
|
|
|
|
|
|
|
#############################################################################
|
1998
|
|
|
|
|
|
|
#NET (Pajek) file format methods #
|
1999
|
|
|
|
|
|
|
#############################################################################
|
2000
|
|
|
|
|
|
|
{
|
2001
|
|
|
|
|
|
|
sub inputGraphfromNET {
|
2002
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
2003
|
|
|
|
|
|
|
|
2004
|
|
|
|
|
|
|
use Regexp::Common qw /delimited/;
|
2005
|
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
|
if (!ref($self)) {
|
2007
|
|
|
|
|
|
|
$self = Graph::Dijkstra->new();
|
2008
|
|
|
|
|
|
|
}
|
2009
|
|
|
|
|
|
|
|
2010
|
|
|
|
|
|
|
open(my $infile, '<:encoding(UTF-8)', $filename) or croak "inputGraphfromNET: could not open '$filename' for input";
|
2011
|
|
|
|
|
|
|
|
2012
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: opened '$filename' for input\n" if $VERBOSE;
|
2013
|
|
|
|
|
|
|
|
2014
|
|
|
|
|
|
|
my $nodes = 0;
|
2015
|
|
|
|
|
|
|
while (my $line = <$infile>) {
|
2016
|
|
|
|
|
|
|
if ($line =~ /^\*vertices\s+(\d+)/ix) {
|
2017
|
|
|
|
|
|
|
$nodes = $1;
|
2018
|
|
|
|
|
|
|
last;
|
2019
|
|
|
|
|
|
|
}
|
2020
|
|
|
|
|
|
|
}
|
2021
|
|
|
|
|
|
|
croak "inputGraphfromNET: vertices element not found" if !$nodes;
|
2022
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: vertices = $nodes\n" if $VERBOSE;
|
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
my $nodecount = 0;
|
2025
|
|
|
|
|
|
|
my $edgecount = 0;
|
2026
|
|
|
|
|
|
|
my $dupedgecount = 0;
|
2027
|
|
|
|
|
|
|
|
2028
|
|
|
|
|
|
|
my $quotedRE = $RE{delimited}{-delim=>'"'};
|
2029
|
|
|
|
|
|
|
#print "quotedRE = '$quotedRE'\n";
|
2030
|
|
|
|
|
|
|
|
2031
|
|
|
|
|
|
|
my $nextSection = '';
|
2032
|
|
|
|
|
|
|
foreach my $i (1 .. $nodes) {
|
2033
|
|
|
|
|
|
|
my $line = '';
|
2034
|
|
|
|
|
|
|
while(1) {
|
2035
|
|
|
|
|
|
|
$line = <$infile>;
|
2036
|
|
|
|
|
|
|
chomp $line;
|
2037
|
|
|
|
|
|
|
croak "inputGraphfromNET: unexpected EOF in vertices section" if !defined($line);
|
2038
|
|
|
|
|
|
|
last if substr($line,0,1) ne '%';
|
2039
|
|
|
|
|
|
|
}
|
2040
|
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
|
if (substr($line,0,1) eq '*') {
|
2042
|
|
|
|
|
|
|
chomp $line;
|
2043
|
|
|
|
|
|
|
$nextSection = lc($line);
|
2044
|
|
|
|
|
|
|
last;
|
2045
|
|
|
|
|
|
|
}
|
2046
|
|
|
|
|
|
|
|
2047
|
|
|
|
|
|
|
if ($line =~ /^\s*(\d+)\s+($quotedRE)/ix) {
|
2048
|
|
|
|
|
|
|
my $id = $1;
|
2049
|
|
|
|
|
|
|
my $label = $2;
|
2050
|
|
|
|
|
|
|
$label = substr($label,1,-1); #strip quotes
|
2051
|
|
|
|
|
|
|
$self->node( {id=>$id, label=>$label} );
|
2052
|
|
|
|
|
|
|
$nodecount++;
|
2053
|
|
|
|
|
|
|
}
|
2054
|
|
|
|
|
|
|
}
|
2055
|
|
|
|
|
|
|
if ($nextSection and $nodecount == 0) {
|
2056
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: empty vertices section (no node labels). Generating node ID values 1 .. $nodes\n" if $VERBOSE;
|
2057
|
|
|
|
|
|
|
foreach my $i (1 .. $nodes) {
|
2058
|
|
|
|
|
|
|
$self->node( {id=>$i, label=>$EMPTY_STRING} );
|
2059
|
|
|
|
|
|
|
$nodecount++;
|
2060
|
|
|
|
|
|
|
}
|
2061
|
|
|
|
|
|
|
}
|
2062
|
|
|
|
|
|
|
elsif ($nodes != $nodecount) {
|
2063
|
|
|
|
|
|
|
die "inputGraphfromNET: internal logic error: # vertices ($nodes) != # read nodes ($nodecount)";
|
2064
|
|
|
|
|
|
|
}
|
2065
|
|
|
|
|
|
|
|
2066
|
|
|
|
|
|
|
if ($nextSection =~ /^(\*\w+)/) {
|
2067
|
|
|
|
|
|
|
$nextSection = $1;
|
2068
|
|
|
|
|
|
|
}
|
2069
|
|
|
|
|
|
|
elsif ($nextSection) {
|
2070
|
|
|
|
|
|
|
die "inputGraphfromNET: internal logic error. Did not recognize next section '$nextSection' in NET (pajek) file.";
|
2071
|
|
|
|
|
|
|
}
|
2072
|
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
|
croak "inputGraphfromNET: input file contains *arclist section. Not supported." if $nextSection eq '*arclist';
|
2074
|
|
|
|
|
|
|
croak "inputGraphfromNET: input file contains *edgelist section. Not supported." if $nextSection eq '*edgelist';
|
2075
|
|
|
|
|
|
|
|
2076
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: next section is '$nextSection'\n" if $nextSection and $VERBOSE;
|
2077
|
|
|
|
|
|
|
|
2078
|
|
|
|
|
|
|
while (1) {
|
2079
|
|
|
|
|
|
|
|
2080
|
|
|
|
|
|
|
if ($nextSection ne '*arcs' and $nextSection ne '*edges') {
|
2081
|
|
|
|
|
|
|
$nextSection = '';
|
2082
|
|
|
|
|
|
|
while (my $line = <$infile>) {
|
2083
|
|
|
|
|
|
|
if ($line =~ /^(\*(?:edges|arcs))/i) {
|
2084
|
|
|
|
|
|
|
$nextSection = lc($1);
|
2085
|
|
|
|
|
|
|
last;
|
2086
|
|
|
|
|
|
|
}
|
2087
|
|
|
|
|
|
|
}
|
2088
|
|
|
|
|
|
|
last if !$nextSection;
|
2089
|
|
|
|
|
|
|
}
|
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
my $edgeDirected = ($nextSection eq '*edges') ? 'undirected' : 'directed';
|
2092
|
|
|
|
|
|
|
$nextSection = '';
|
2093
|
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
|
while (my $line = <$infile>) {
|
2095
|
|
|
|
|
|
|
chomp $line;
|
2096
|
|
|
|
|
|
|
next if !$line;
|
2097
|
|
|
|
|
|
|
next if substr($line,0,1) eq '%';
|
2098
|
|
|
|
|
|
|
if ($line =~ /^(\*\w+)/) {
|
2099
|
|
|
|
|
|
|
$nextSection = lc($1);
|
2100
|
|
|
|
|
|
|
last;
|
2101
|
|
|
|
|
|
|
}
|
2102
|
|
|
|
|
|
|
if ($line =~ /^\s+(\d+)\s+(\d+)\s+([0-9\.]+)/s) {
|
2103
|
|
|
|
|
|
|
my $sourceID = $1;
|
2104
|
|
|
|
|
|
|
my $targetID = $2;
|
2105
|
|
|
|
|
|
|
my $weight = $3;
|
2106
|
|
|
|
|
|
|
$dupedgecount++ if $self->edgeExists( { sourceID=>$sourceID, targetID=>$targetID } );
|
2107
|
|
|
|
|
|
|
$self->edge( { sourceID=>$sourceID, targetID=>$targetID, weight=>$weight, directed=>$edgeDirected } );
|
2108
|
|
|
|
|
|
|
$edgecount++;
|
2109
|
|
|
|
|
|
|
}
|
2110
|
|
|
|
|
|
|
else {
|
2111
|
|
|
|
|
|
|
chomp $line;
|
2112
|
|
|
|
|
|
|
carp "inputGraphfromNET: unrecognized input line (maybe edge with no weight?) =>$line<=";
|
2113
|
|
|
|
|
|
|
last;
|
2114
|
|
|
|
|
|
|
}
|
2115
|
|
|
|
|
|
|
}
|
2116
|
|
|
|
|
|
|
last if !$nextSection;
|
2117
|
|
|
|
|
|
|
}
|
2118
|
|
|
|
|
|
|
close($infile);
|
2119
|
|
|
|
|
|
|
|
2120
|
|
|
|
|
|
|
carp "inputGraphfromNET: no nodes read from '$filename'" if !$nodecount;
|
2121
|
|
|
|
|
|
|
carp "inputGraphfromNET: no edges read from '$filename'" if !$edgecount;
|
2122
|
|
|
|
|
|
|
|
2123
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: found $nodecount nodes and $edgecount edges\n" if $VERBOSE;
|
2124
|
|
|
|
|
|
|
print {$verboseOutfile} "inputGraphfromNET: found $dupedgecount duplicate edges\n" if $dupedgecount and $VERBOSE;
|
2125
|
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
|
return $self;
|
2127
|
|
|
|
|
|
|
}
|
2128
|
|
|
|
|
|
|
|
2129
|
|
|
|
|
|
|
sub outputGraphtoNET {
|
2130
|
|
|
|
|
|
|
my ($self, $filename) = @_;
|
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
open(my $outfile, '>:encoding(UTF-8)', $filename) or croak "outputGraphtoNET: could not open '$filename' for output";
|
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: opened '$filename' for output\n" if $VERBOSE;
|
2135
|
|
|
|
|
|
|
|
2136
|
|
|
|
|
|
|
my %edges = ();
|
2137
|
|
|
|
|
|
|
my $nodecount = 0;
|
2138
|
|
|
|
|
|
|
my $edgecount = 0;
|
2139
|
|
|
|
|
|
|
my $useConsecutiveNumericIDs = 1;
|
2140
|
|
|
|
|
|
|
my $hasNonBlankLabels = 0;
|
2141
|
|
|
|
|
|
|
my $highestNumericID = 0;
|
2142
|
|
|
|
|
|
|
my $lowestNumericID = $PINF;
|
2143
|
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
|
my @nodeList = $self->nodeList();
|
2145
|
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
|
foreach my $nodeHref (@nodeList) {
|
2147
|
|
|
|
|
|
|
$nodecount++;
|
2148
|
|
|
|
|
|
|
my $nodeID = $nodeHref->{id};
|
2149
|
|
|
|
|
|
|
my $label = $nodeHref->{label};
|
2150
|
|
|
|
|
|
|
if ($useConsecutiveNumericIDs) {
|
2151
|
|
|
|
|
|
|
if ($nodeID =~ /^\d+$/) {
|
2152
|
|
|
|
|
|
|
$highestNumericID = $nodeID if $nodeID > $highestNumericID;
|
2153
|
|
|
|
|
|
|
$lowestNumericID = $nodeID if $nodeID < $lowestNumericID;
|
2154
|
|
|
|
|
|
|
}
|
2155
|
|
|
|
|
|
|
else {
|
2156
|
|
|
|
|
|
|
$useConsecutiveNumericIDs = 0;
|
2157
|
|
|
|
|
|
|
}
|
2158
|
|
|
|
|
|
|
}
|
2159
|
|
|
|
|
|
|
|
2160
|
|
|
|
|
|
|
$hasNonBlankLabels = 1 if (!$hasNonBlankLabels and $label ne $EMPTY_STRING);
|
2161
|
|
|
|
|
|
|
}
|
2162
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: internal graph has non-blank labels.\n" if $VERBOSE and $hasNonBlankLabels;
|
2163
|
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
|
if ($useConsecutiveNumericIDs) {
|
2165
|
|
|
|
|
|
|
if ($highestNumericID != $nodecount or $lowestNumericID != 1) {
|
2166
|
|
|
|
|
|
|
$useConsecutiveNumericIDs = 0;
|
2167
|
|
|
|
|
|
|
}
|
2168
|
|
|
|
|
|
|
}
|
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
|
2171
|
|
|
|
|
|
|
{
|
2172
|
|
|
|
|
|
|
my $now_string = localtime;
|
2173
|
|
|
|
|
|
|
print {$outfile} "% Generated by Graph::Dijkstra on $now_string\n";
|
2174
|
|
|
|
|
|
|
}
|
2175
|
|
|
|
|
|
|
|
2176
|
|
|
|
|
|
|
print {$outfile} "*Vertices $nodecount\n";
|
2177
|
|
|
|
|
|
|
|
2178
|
|
|
|
|
|
|
my $hasArcs = 0;
|
2179
|
|
|
|
|
|
|
my $hasEdges = 0;
|
2180
|
|
|
|
|
|
|
|
2181
|
|
|
|
|
|
|
if ($useConsecutiveNumericIDs) {
|
2182
|
|
|
|
|
|
|
|
2183
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: internal graph has consecutive numeric IDs.\n" if $VERBOSE;
|
2184
|
|
|
|
|
|
|
$nodecount = 0;
|
2185
|
|
|
|
|
|
|
foreach my $nodeHref (sort { $a->{id} <=> $b->{id} } @nodeList) {
|
2186
|
|
|
|
|
|
|
|
2187
|
|
|
|
|
|
|
$nodecount++;
|
2188
|
|
|
|
|
|
|
|
2189
|
|
|
|
|
|
|
my $nodeID = $nodeHref->{id};
|
2190
|
|
|
|
|
|
|
my $label = $nodeHref->{label};
|
2191
|
|
|
|
|
|
|
croak "outputGraphtoNET: node IDs are not consecutive numeric integers starting at 1" if ($nodeID != $nodecount);
|
2192
|
|
|
|
|
|
|
|
2193
|
|
|
|
|
|
|
if ($hasNonBlankLabels) {
|
2194
|
|
|
|
|
|
|
printf {$outfile} "%7d \"%s\"\n", $nodeID, $label;
|
2195
|
|
|
|
|
|
|
}
|
2196
|
|
|
|
|
|
|
|
2197
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
2198
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
2199
|
|
|
|
|
|
|
my $edgeDirected = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
2200
|
|
|
|
|
|
|
if ( ($edgeDirected eq 'undirected' and !exists($edges{$targetID}{$nodeID}) ) or $edgeDirected eq 'directed') {
|
2201
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
2202
|
|
|
|
|
|
|
$edges{$nodeID}{$targetID}{directed} = $edgeDirected;
|
2203
|
|
|
|
|
|
|
if ($edgeDirected eq 'directed') {
|
2204
|
|
|
|
|
|
|
$hasArcs++;
|
2205
|
|
|
|
|
|
|
}
|
2206
|
|
|
|
|
|
|
else {
|
2207
|
|
|
|
|
|
|
$hasEdges++;
|
2208
|
|
|
|
|
|
|
}
|
2209
|
|
|
|
|
|
|
}
|
2210
|
|
|
|
|
|
|
}
|
2211
|
|
|
|
|
|
|
}
|
2212
|
|
|
|
|
|
|
}
|
2213
|
|
|
|
|
|
|
}
|
2214
|
|
|
|
|
|
|
else {
|
2215
|
|
|
|
|
|
|
if ($VERBOSE) {
|
2216
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: internal graph node ID values are not consecutive integer values starting at 1.\n";
|
2217
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: internal graph node ID values not perserved in output\n";
|
2218
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: generating consecutive integer ID values in output\n";
|
2219
|
|
|
|
|
|
|
}
|
2220
|
|
|
|
|
|
|
|
2221
|
|
|
|
|
|
|
my %nodeIDtoNumericID = ();
|
2222
|
|
|
|
|
|
|
foreach my $i (0 .. $#nodeList) {
|
2223
|
|
|
|
|
|
|
$nodeIDtoNumericID{ $nodeList[$i]->{id} } = $i+1;
|
2224
|
|
|
|
|
|
|
}
|
2225
|
|
|
|
|
|
|
|
2226
|
|
|
|
|
|
|
foreach my $nodeID (sort {$nodeIDtoNumericID{$a} <=> $nodeIDtoNumericID{$b}} keys %nodeIDtoNumericID) {
|
2227
|
|
|
|
|
|
|
if ($hasNonBlankLabels) {
|
2228
|
|
|
|
|
|
|
printf {$outfile} "%7d \"%s\"\n", $nodeIDtoNumericID{$nodeID}, $self->{graph}{$nodeID}{label};
|
2229
|
|
|
|
|
|
|
}
|
2230
|
|
|
|
|
|
|
|
2231
|
|
|
|
|
|
|
if (exists($self->{graph}{$nodeID}{edges})) {
|
2232
|
|
|
|
|
|
|
my $numericNodeID = $nodeIDtoNumericID{$nodeID};
|
2233
|
|
|
|
|
|
|
foreach my $targetID (keys %{$self->{graph}{$nodeID}{edges}}) {
|
2234
|
|
|
|
|
|
|
my $edgeDirected = $self->{graph}{$nodeID}{edges}{$targetID}{directed};
|
2235
|
|
|
|
|
|
|
my $numericTargetID = $nodeIDtoNumericID{$targetID};
|
2236
|
|
|
|
|
|
|
if ( ($edgeDirected eq 'undirected' and !exists($edges{$numericTargetID}{$numericNodeID})) or $edgeDirected eq 'directed') {
|
2237
|
|
|
|
|
|
|
$edges{$numericNodeID}{$numericTargetID}{weight} = $self->{graph}{$nodeID}{edges}{$targetID}{weight};
|
2238
|
|
|
|
|
|
|
$edges{$numericNodeID}{$numericTargetID}{directed} = $edgeDirected;
|
2239
|
|
|
|
|
|
|
if ($edgeDirected eq 'directed') {
|
2240
|
|
|
|
|
|
|
$hasArcs++;
|
2241
|
|
|
|
|
|
|
}
|
2242
|
|
|
|
|
|
|
else {
|
2243
|
|
|
|
|
|
|
$hasEdges++;
|
2244
|
|
|
|
|
|
|
}
|
2245
|
|
|
|
|
|
|
}
|
2246
|
|
|
|
|
|
|
}
|
2247
|
|
|
|
|
|
|
}
|
2248
|
|
|
|
|
|
|
}
|
2249
|
|
|
|
|
|
|
}
|
2250
|
|
|
|
|
|
|
|
2251
|
|
|
|
|
|
|
if ($hasEdges) {
|
2252
|
|
|
|
|
|
|
print {$outfile} "*Edges\n";
|
2253
|
|
|
|
|
|
|
foreach my $sourceID (sort {$a <=> $b} keys %edges) {
|
2254
|
|
|
|
|
|
|
foreach my $targetID (sort {$a <=> $b} keys %{$edges{$sourceID}} ) {
|
2255
|
|
|
|
|
|
|
next if $edges{$sourceID}{$targetID}{directed} eq 'directed';
|
2256
|
|
|
|
|
|
|
printf {$outfile} "%7d %7d %10s\n", $sourceID, $targetID, "$edges{$sourceID}{$targetID}{weight}";
|
2257
|
|
|
|
|
|
|
$edgecount++;
|
2258
|
|
|
|
|
|
|
}
|
2259
|
|
|
|
|
|
|
}
|
2260
|
|
|
|
|
|
|
}
|
2261
|
|
|
|
|
|
|
if ($hasArcs) {
|
2262
|
|
|
|
|
|
|
print {$outfile} "*Arcs\n";
|
2263
|
|
|
|
|
|
|
foreach my $sourceID (sort {$a <=> $b} keys %edges) {
|
2264
|
|
|
|
|
|
|
foreach my $targetID (sort {$a <=> $b} keys %{$edges{$sourceID}} ) {
|
2265
|
|
|
|
|
|
|
next if $edges{$sourceID}{$targetID}{directed} eq 'undirected';
|
2266
|
|
|
|
|
|
|
printf {$outfile} "%7d %7d %10s\n", $sourceID, $targetID, "$edges{$sourceID}{$targetID}{weight}";
|
2267
|
|
|
|
|
|
|
$edgecount++;
|
2268
|
|
|
|
|
|
|
}
|
2269
|
|
|
|
|
|
|
}
|
2270
|
|
|
|
|
|
|
}
|
2271
|
|
|
|
|
|
|
close($outfile);
|
2272
|
|
|
|
|
|
|
|
2273
|
|
|
|
|
|
|
print {$verboseOutfile} "outputGraphtoNET: wrote $nodecount nodes and $edgecount edges to '$filename'\n" if $VERBOSE;
|
2274
|
|
|
|
|
|
|
return $self;
|
2275
|
|
|
|
|
|
|
}
|
2276
|
|
|
|
|
|
|
|
2277
|
|
|
|
|
|
|
|
2278
|
|
|
|
|
|
|
} #NET (Pagek) file format methods
|
2279
|
|
|
|
|
|
|
|
2280
|
|
|
|
|
|
|
1;
|
2281
|
|
|
|
|
|
|
|
2282
|
|
|
|
|
|
|
__END__
|