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