projects / scpubgit/stemmatology.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Merge branch 'master' of github.com:tla/stemmatology
[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation / RelationshipStore.pm
CommitLineData
22222af9 1package Text::Tradition::Collation::RelationshipStore;
2
3use strict;
4use warnings;
63778331 5use Text::Tradition::Error;
22222af9 6use Text::Tradition::Collation::Relationship;
a1615ee4 7use TryCatch;
22222af9 8
9use Moose;
10
11=head1 NAME
12
2626f709 13Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
14between readings in a given collation
22222af9 15
16=head1 DESCRIPTION
17
18Text::Tradition is a library for representation and analysis of collated
19texts, particularly medieval ones. The RelationshipStore is an internal object
20of the collation, to keep track of the defined relationships (both specific and
21general) between readings.
22
3ae5e2ad 23=begin testing
24
25use Text::Tradition;
ee801e17 26use TryCatch;
3ae5e2ad 27
28use_ok( 'Text::Tradition::Collation::RelationshipStore' );
29
ee801e17 30# Add some relationships, and delete them
31
32my $cxfile = 't/data/Collatex-16.xml';
33my $t = Text::Tradition->new(
34 'name' => 'inline',
35 'input' => 'CollateX',
36 'file' => $cxfile,
37 );
38my $c = $t->collation;
39
f8331a4d 40my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
ee801e17 41is( scalar @v1, 1, "Added a single relationship" );
42is( $v1[0]->[0], 'n21', "Got correct node 1" );
43is( $v1[0]->[1], 'n22', "Got correct node 2" );
679f17e1 44my @v2 = $c->add_relationship( 'n24', 'n23',
ee801e17 45 { 'type' => 'spelling', 'scope' => 'global' } );
46is( scalar @v2, 2, "Added a global relationship with two instances" );
47@v1 = $c->del_relationship( 'n22', 'n21' );
48is( scalar @v1, 1, "Deleted first relationship" );
679f17e1 49@v2 = $c->del_relationship( 'n12', 'n13' );
ee801e17 50is( scalar @v2, 2, "Deleted second global relationship" );
681893aa 51my @v3 = $c->del_relationship( 'n1', 'n2' );
52is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
ee801e17 53
3ae5e2ad 54=end testing
55
22222af9 56=head1 METHODS
57
58=head2 new( collation => $collation );
59
60Creates a new relationship store for the given collation.
61
62=cut
63
64has 'collation' => (
65 is => 'ro',
66 isa => 'Text::Tradition::Collation',
67 required => 1,
68 weak_ref => 1,
69 );
70
71has 'scopedrels' => (
72 is => 'ro',
73 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
74 default => sub { {} },
75 );
76
77has 'graph' => (
78 is => 'ro',
79 isa => 'Graph',
80 default => sub { Graph->new( undirected => 1 ) },
81 handles => {
82 relationships => 'edges',
83 add_reading => 'add_vertex',
84 delete_reading => 'delete_vertex',
85 },
86 );
87
3ae5e2ad 88=head2 get_relationship
89
90Return the relationship object, if any, that exists between two readings.
91
92=cut
93
94sub get_relationship {
4633f9e4 95 my $self = shift;
96 my @vector;
97 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
98 # Dereference the edge arrayref that was passed.
99 my $edge = shift;
100 @vector = @$edge;
101 } else {
102 @vector = @_;
103 }
3ae5e2ad 104 my $relationship;
105 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
106 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
ca6e6095 107 }
3ae5e2ad 108 return $relationship;
109}
110
111sub _set_relationship {
112 my( $self, $relationship, @vector ) = @_;
113 $self->graph->add_edge( @vector );
114 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
115}
a1615ee4 116
22222af9 117=head2 create
118
119Create a new relationship with the given options and return it.
120Warn and return undef if the relationship cannot be created.
121
122=cut
123
124sub create {
125 my( $self, $options ) = @_;
126 # Check to see if a relationship exists between the two given readings
127 my $source = delete $options->{'orig_a'};
128 my $target = delete $options->{'orig_b'};
3ae5e2ad 129 my $rel = $self->get_relationship( $source, $target );
130 if( $rel ) {
3d14b48e 131 if( $rel->type eq 'collated' ) {
132 # Always replace a 'collated' relationship with a more descriptive
133 # one, if asked.
134 $self->del_relationship( $source, $target );
135 } elsif( $rel->type ne $options->{'type'} ) {
63778331 136 throw( "Another relationship of type " . $rel->type
137 . " already exists between $source and $target" );
22222af9 138 } else {
139 return $rel;
140 }
141 }
142
143 # Check to see if a nonlocal relationship is defined for the two readings
144 $rel = $self->scoped_relationship( $options->{'reading_a'},
145 $options->{'reading_b'} );
146 if( $rel && $rel->type eq $options->{'type'} ) {
147 return $rel;
148 } elsif( $rel ) {
63778331 149 throw( sprintf( "Relationship of type %s with scope %s already defined for readings %s and %s", $rel->type, $rel->scope, $options->{'reading_a'}, $options->{'reading_b'} ) );
22222af9 150 } else {
151 $rel = Text::Tradition::Collation::Relationship->new( $options );
152 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
153 return $rel;
154 }
155}
156
157=head2 add_scoped_relationship( $rel )
158
159Keep track of relationships defined between specific readings that are scoped
160non-locally. Key on whichever reading occurs first alphabetically.
161
162=cut
163
164sub add_scoped_relationship {
165 my( $self, $rel ) = @_;
f222800e 166 my $rdga = $rel->type eq 'orthographic' ? $rel->reading_a : lc( $rel->reading_a );
167 my $rdgb = $rel->type eq 'orthographic' ? $rel->reading_b : lc( $rel->reading_b );
168 my $r = $self->scoped_relationship( $rdga, $rdgb );
22222af9 169 if( $r ) {
170 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
f222800e 171 $r->type, $rdga, $rdgb );
22222af9 172 return;
173 }
f222800e 174 my( $first, $second ) = sort ( $rdga, $rdgb );
175 $self->scopedrels->{$first}->{$second} = $rel;
22222af9 176}
177
178=head2 scoped_relationship( $reading_a, $reading_b )
179
180Returns the general (document-level or global) relationship that has been defined
181between the two reading strings. Returns undef if there is no general relationship.
182
183=cut
184
185sub scoped_relationship {
186 my( $self, $rdga, $rdgb ) = @_;
187 my( $first, $second ) = sort( $rdga, $rdgb );
188 if( exists $self->scopedrels->{$first}->{$second} ) {
189 return $self->scopedrels->{$first}->{$second};
190 } else {
191 return undef;
192 }
193}
194
195=head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
196
197Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
198for the possible options) between the readings given in $source and $target. Sets
199up a scoped relationship between $sourcetext and $targettext if the relationship is
200scoped non-locally.
201
202Returns a status boolean and a list of all reading pairs connected by the call to
203add_relationship.
204
205=cut
206
207sub add_relationship {
208 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
209
ca6e6095 210 my $relationship;
211 my $thispaironly;
212 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
213 $relationship = $options;
214 $thispaironly = 1; # If existing rel, set only where asked.
215 } else {
216 # Check the options
217 $options->{'scope'} = 'local' unless $options->{'scope'};
bf6e338d 218 $options->{'scope'} = 'local' if $options->{'type'} eq 'collated';
8d5c8893 219 $options->{'scope'} = 'local' if $options->{'type'} eq 'transposition';
ca6e6095 220
221 my( $is_valid, $reason ) =
222 $self->relationship_valid( $source, $target, $options->{'type'} );
223 unless( $is_valid ) {
224 throw( "Invalid relationship: $reason" );
225 }
226
227 # Try to create the relationship object.
228 $options->{'reading_a'} = $source_rdg->text;
229 $options->{'reading_b'} = $target_rdg->text;
230 $options->{'orig_a'} = $source;
231 $options->{'orig_b'} = $target;
0ac5e750 232 if( $options->{'scope'} ne 'local' ) {
233 # Is there a relationship with this a & b already?
f222800e 234 # Case-insensitive for non-orthographics.
235 my $rdga = $options->{'type'} eq 'orthographic'
236 ? $options->{'reading_a'} : lc( $options->{'reading_a'} );
237 my $rdgb = $options->{'type'} eq 'orthographic'
238 ? $options->{'reading_b'} : lc( $options->{'reading_b'} );
239 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
0ac5e750 240 if( $otherrel && $otherrel->type eq $options->{type}
241 && $otherrel->scope eq $options->{scope} ) {
242 warn "Applying existing scoped relationship";
243 $relationship = $otherrel;
244 }
245 }
246 $relationship = $self->create( $options ) unless $relationship; # Will throw on error
22222af9 247 }
ca6e6095 248
22222af9 249
250 # Find all the pairs for which we need to set the relationship.
bf6e338d 251 my @vectors = [ $source, $target ];
ca6e6095 252 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
bf6e338d 253 push( @vectors, $self->_find_applicable( $relationship ) );
f222800e 254 }
bf6e338d 255
22222af9 256 # Now set the relationship(s).
257 my @pairs_set;
258 foreach my $v ( @vectors ) {
3ae5e2ad 259 my $rel = $self->get_relationship( @$v );
ca6e6095 260 if( $rel && $rel ne $relationship ) {
63778331 261 if( $rel->nonlocal ) {
262 throw( "Found conflicting relationship at @$v" );
a2ed66b2 263 } elsif( $rel->type ne 'collated' ) {
264 # Replace a collation relationship; leave any other sort in place.
13e893dc 265 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
266 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
267 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
268 warn sprintf( "Not overriding local relationship %s with global %s "
269 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
270 @$v, $rel->reading_a, $rel->reading_b );
271 next;
272 }
63778331 273 }
22222af9 274 }
8d5c8893 275 map { $self->_drop_collations( $_ ) } @$v;
3ae5e2ad 276 $self->_set_relationship( $relationship, @$v );
22222af9 277 push( @pairs_set, $v );
278 }
279
63778331 280 return @pairs_set;
22222af9 281}
282
9d829138 283=head2 del_scoped_relationship( $reading_a, $reading_b )
284
285Returns the general (document-level or global) relationship that has been defined
286between the two reading strings. Returns undef if there is no general relationship.
287
288=cut
289
290sub del_scoped_relationship {
291 my( $self, $rdga, $rdgb ) = @_;
292 my( $first, $second ) = sort( $rdga, $rdgb );
293 return delete $self->scopedrels->{$first}->{$second};
294}
295
bf6e338d 296sub _find_applicable {
297 my( $self, $rel ) = @_;
298 my $c = $self->collation;
299 # TODO Someday we might use a case sensitive language.
300 my $lang = $c->tradition->language;
301 my @vectors;
302 my @identical_readings;
303 if( $rel->type eq 'orthographic' ) {
304 @identical_readings = grep { $_->text eq $rel->reading_a }
305 $c->readings;
306 } else {
307 @identical_readings = grep { lc( $_->text ) eq lc( $rel->reading_a ) }
308 $c->readings;
309 }
310 foreach my $ir ( @identical_readings ) {
311 my @itarget;
312 if( $rel->type eq 'orthographic' ) {
313 @itarget = grep { $_->rank == $ir->rank
314 && $_->text eq $rel->reading_b } $c->readings;
315 } else {
316 @itarget = grep { $_->rank == $ir->rank
317 && lc( $_->text ) eq lc( $rel->reading_b ) } $c->readings;
318 }
319 if( @itarget ) {
320 # Warn if there is more than one hit with no orth link between them.
321 my $itmain = shift @itarget;
322 if( @itarget ) {
323 my %all_targets;
324 map { $all_targets{$_} = 1 } @itarget;
325 map { delete $all_targets{$_} }
326 $self->related_readings( $itmain,
327 sub { $_[0]->type eq 'orthographic' } );
328 warn "More than one unrelated reading with text " . $itmain->text
329 . " at rank " . $ir->rank . "!" if keys %all_targets;
330 }
331 push( @vectors, [ $ir->id, $itmain->id ] );
332 }
333 }
334 return @vectors;
335}
336
ee801e17 337=head2 del_relationship( $source, $target )
338
339Removes the relationship between the given readings. If the relationship is
340non-local, removes the relationship everywhere in the graph.
341
342=cut
343
344sub del_relationship {
345 my( $self, $source, $target ) = @_;
346 my $rel = $self->get_relationship( $source, $target );
681893aa 347 return () unless $rel; # Nothing to delete; return an empty set.
ee801e17 348 my @vectors = ( [ $source, $target ] );
349 $self->_remove_relationship( $source, $target );
350 if( $rel->nonlocal ) {
351 # Remove the relationship wherever it occurs.
9d829138 352 # Remove the relationship wherever it occurs.
ee801e17 353 my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
354 $self->relationships;
355 foreach my $re ( @rel_edges ) {
356 $self->_remove_relationship( @$re );
357 push( @vectors, $re );
358 }
9d829138 359 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
ee801e17 360 }
361 return @vectors;
362}
363
ca6e6095 364sub _remove_relationship {
365 my( $self, @vector ) = @_;
366 $self->graph->delete_edge( @vector );
367}
368
22222af9 369=head2 relationship_valid( $source, $target, $type )
370
371Checks whether a relationship of type $type may exist between the readings given
372in $source and $target. Returns a tuple of ( status, message ) where status is
373a yes/no boolean and, if the answer is no, message gives the reason why.
374
375=cut
376
377sub relationship_valid {
378 my( $self, $source, $target, $rel ) = @_;
379 my $c = $self->collation;
380 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
381 # Check that the two readings do (for a repetition) or do not (for
382 # a transposition) appear in the same witness.
91e21ac6 383 # If we haven't made reading paths yet, take it on faith.
384 return( 1, "no paths yet" ) unless $c->sequence->successors( $c->start );
385
386 # We have some paths, so carry on.
22222af9 387 my %seen_wits;
388 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
389 foreach my $w ( $c->reading_witnesses( $target ) ) {
390 if( $seen_wits{$w} ) {
391 return ( 0, "Readings both occur in witness $w" )
392 if $rel eq 'transposition';
393 return ( 1, "ok" ) if $rel eq 'repetition';
d6936dea 394 }
22222af9 395 }
91e21ac6 396 # For transpositions, there should also be a path from one reading
397 # to the other.
398 if( $rel eq 'transposition' ) {
399 my( %sourceseq, %targetseq );
400 map { $sourceseq{$_} = 1 } $c->sequence->all_successors( $source );
401 map { $targetseq{$_} = 1 } $c->sequence->all_successors( $target );
402 return( 0, "Readings are parallel" )
403 unless $sourceseq{$target} || $targetseq{$source};
404 }
22222af9 405 return $rel eq 'transposition' ? ( 1, "ok" )
406 : ( 0, "Readings occur only in distinct witnesses" );
91e21ac6 407 }
408 if( $rel ne 'repetition' ) {
22222af9 409 # Check that linking the source and target in a relationship won't lead
91e21ac6 410 # to a path loop for any witness. If they have the same rank then
411 # they are parallel by definition.
412 # For transpositions, we want the opposite result: it is only valid if
413 # the readings cannot be parallel.
414 my $sourcerank = $c->reading( $source )->has_rank
415 ? $c->reading( $source )->rank : undef;
416 my $targetrank = $c->reading( $target )->has_rank
417 ? $c->reading( $target )->rank : undef;
418 if( $sourcerank && $targetrank && $sourcerank == $targetrank ) {
419 return( 0, "Cannot transpose readings of same rank" )
420 if $rel eq 'transposition';
421 return( 1, "ok" );
422 }
a1615ee4 423
424 # Otherwise, first make a lookup table of all the
22222af9 425 # readings related to either the source or the target.
426 my @proposed_related = ( $source, $target );
778251a6 427 # Drop the collation links of source and target, unless we want to
428 # add a collation relationship.
91e21ac6 429 my @dropped;
778251a6 430 foreach my $r ( ( $source, $target ) ) {
91e21ac6 431 push( @dropped, $self->_drop_collations( $r ) )
432 unless $rel eq 'collated';
778251a6 433 push( @proposed_related, $self->related_readings( $r, 'colocated' ) );
434 }
91e21ac6 435 # Also drop any collation links at intermediate ranks.
436 foreach my $rank ( $sourcerank+1 .. $targetrank-1 ) {
437 map { push( @dropped, $self->_drop_collations( $_ ) ) }
438 $c->readings_at_rank( $rank );
439 }
22222af9 440 my %pr_ids;
441 map { $pr_ids{ $_ } = 1 } @proposed_related;
442
a1615ee4 443 # The cumulative predecessors and successors of the proposed-related readings
444 # should not overlap.
445 my %all_pred;
446 my %all_succ;
22222af9 447 foreach my $pr ( keys %pr_ids ) {
a1615ee4 448 map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
449 map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
450 }
451 foreach my $k ( keys %all_pred ) {
91e21ac6 452 if( exists $all_succ{$k} ) {
453 $self->_restore_collations( @dropped );
454 return( 1, "ok" ) if $rel eq 'transposition';
455 return( 0, "Relationship would create witness loop" );
456 }
a1615ee4 457 }
458 foreach my $k ( keys %pr_ids ) {
91e21ac6 459 if( exists $all_pred{$k} || exists $all_succ{$k} ) {
460 $self->_restore_collations( @dropped );
461 return( 1, "ok" ) if $rel eq 'transposition';
462 return( 0, "Relationship would create witness loop" );
463 }
464 }
465 if( $rel eq 'transposition' ) {
466 $self->_restore_collations( @dropped );
467 return ( 0, "Cannot transpose parallel readings" );
a1615ee4 468 }
22222af9 469 return ( 1, "ok" );
470 }
471}
472
778251a6 473sub _drop_collations {
474 my( $self, $reading ) = @_;
91e21ac6 475 my @deleted;
778251a6 476 foreach my $n ( $self->graph->neighbors( $reading ) ) {
477 if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
478 $self->del_relationship( $reading, $n );
91e21ac6 479 push( @deleted, [ $reading, $n ] );
480 }
481 }
482 return @deleted;
483}
484
485sub _restore_collations {
486 my( $self, @vectors ) = @_;
487 foreach my $v ( @vectors ) {
488 try {
489 $self->add_relationship( @$v, { 'type' => 'collated' } );
490 } catch ( Text::Tradition::Error $e ) {
491 warn "Could not restore collation " . join( ' -> ', @$v );
778251a6 492 }
493 }
494}
495
7f52eac8 496=head2 related_readings( $reading, $filter )
22222af9 497
498Returns a list of readings that are connected via relationship links to $reading.
7f52eac8 499If $filter is set to a subroutine ref, returns only those related readings where
500$filter( $relationship ) returns a true value.
22222af9 501
502=cut
503
504sub related_readings {
7f52eac8 505 my( $self, $reading, $filter ) = @_;
22222af9 506 my $return_object;
507 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
508 $reading = $reading->id;
509 $return_object = 1;
510 }
c84275ff 511 my @answer;
7f52eac8 512 if( $filter ) {
513 # Backwards compat
514 if( $filter eq 'colocated' ) {
515 $filter = sub { $_[0]->colocated };
516 }
c84275ff 517 my %found = ( $reading => 1 );
518 my $check = [ $reading ];
519 my $iter = 0;
520 while( @$check ) {
c84275ff 521 my $more = [];
522 foreach my $r ( @$check ) {
523 foreach my $nr ( $self->graph->neighbors( $r ) ) {
7f52eac8 524 if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
c84275ff 525 push( @$more, $nr ) unless exists $found{$nr};
526 $found{$nr} = 1;
527 }
528 }
529 }
530 $check = $more;
22222af9 531 }
7f52eac8 532 delete $found{$reading};
c84275ff 533 @answer = keys %found;
534 } else {
535 @answer = $self->graph->all_reachable( $reading );
22222af9 536 }
537 if( $return_object ) {
538 my $c = $self->collation;
c84275ff 539 return map { $c->reading( $_ ) } @answer;
22222af9 540 } else {
c84275ff 541 return @answer;
22222af9 542 }
543}
544
545=head2 merge_readings( $kept, $deleted );
546
547Makes a best-effort merge of the relationship links between the given readings, and
548stops tracking the to-be-deleted reading.
549
550=cut
551
552sub merge_readings {
553 my( $self, $kept, $deleted, $combined ) = @_;
91e21ac6 554 # Delete any relationship between kept and deleted
555 $self->del_relationship( $kept, $deleted );
22222af9 556 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
557 # Get the pair of kept / rel
558 my @vector = ( $kept );
559 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
560 next if $vector[0] eq $vector[1]; # Don't add a self loop
561
562 # If kept changes its text, drop the relationship.
563 next if $combined;
564
f222800e 565 # If kept / rel already has a relationship, just keep the old
3ae5e2ad 566 my $rel = $self->get_relationship( @vector );
f222800e 567 next if $rel;
22222af9 568
569 # Otherwise, adopt the relationship that would be deleted.
3ae5e2ad 570 $rel = $self->get_relationship( @$edge );
571 $self->_set_relationship( $rel, @vector );
22222af9 572 }
573 $self->delete_reading( $deleted );
574}
575
027d819c 576sub _as_graphml {
2626f709 577 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
c84275ff 578
579 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
580 $rgraph->setAttribute( 'edgedefault', 'directed' );
581 $rgraph->setAttribute( 'id', 'relationships', );
582 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
583 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
584 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
585 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
586 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
587
588 # Add the vertices according to their XML IDs
2626f709 589 my %rdg_lookup = ( reverse %$node_hash );
590 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
c84275ff 591 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
592 $n_el->setAttribute( 'id', $n );
2626f709 593 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
c84275ff 594 }
595
596 # Add the relationship edges, with their object information
597 my $edge_ctr = 0;
598 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
599 # Add an edge and fill in its relationship info.
a30ca502 600 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
c84275ff 601 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
602 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
603 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
604 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
605
3ae5e2ad 606 my $rel_obj = $self->get_relationship( @$e );
bbd064a9 607 foreach my $key ( keys %$edge_keys ) {
608 my $value = $rel_obj->$key;
609 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
610 if defined $value;
611 }
c84275ff 612 }
613}
614
615sub _by_xmlid {
2626f709 616 my $tmp_a = $a;
617 my $tmp_b = $b;
618 $tmp_a =~ s/\D//g;
619 $tmp_b =~ s/\D//g;
620 return $tmp_a <=> $tmp_b;
c84275ff 621}
622
623sub _add_graphml_data {
624 my( $el, $key, $value ) = @_;
625 return unless defined $value;
626 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
627 $data_el->setAttribute( 'key', $key );
628 $data_el->appendText( $value );
83d5ac3a 629}
630
63778331 631sub throw {
632 Text::Tradition::Error->throw(
633 'ident' => 'Relationship error',
634 'message' => $_[0],
635 );
636}
637
22222af9 638no Moose;
639__PACKAGE__->meta->make_immutable;
640
6411;
Unnamed repository; edit this file 'description' to name the repository.