File Coverage

blib/lib/Graph/Dijkstra.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


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__