1 package Text::Tradition::Collation::RelationshipStore;
5 use Text::Tradition::Error;
6 use Text::Tradition::Collation::Relationship;
13 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
14 between readings in a given collation
18 Text::Tradition is a library for representation and analysis of collated
19 texts, particularly medieval ones. The RelationshipStore is an internal object
20 of the collation, to keep track of the defined relationships (both specific and
21 general) between readings.
28 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
30 # Add some relationships, and delete them
32 my $cxfile = 't/data/Collatex-16.xml';
33 my $t = Text::Tradition->new(
35 'input' => 'CollateX',
38 my $c = $t->collation;
40 my @v1 = $c->add_relationship( 'n21', 'n22', { 'type' => 'lexical' } );
41 is( scalar @v1, 1, "Added a single relationship" );
42 is( $v1[0]->[0], 'n21', "Got correct node 1" );
43 is( $v1[0]->[1], 'n22', "Got correct node 2" );
44 my @v2 = $c->add_relationship( 'n24', 'n23',
45 { 'type' => 'spelling', 'scope' => 'global' } );
46 is( scalar @v2, 2, "Added a global relationship with two instances" );
47 @v1 = $c->del_relationship( 'n22', 'n21' );
48 is( scalar @v1, 1, "Deleted first relationship" );
49 @v2 = $c->del_relationship( 'n12', 'n13' );
50 is( scalar @v2, 2, "Deleted second global relationship" );
51 my @v3 = $c->del_relationship( 'n1', 'n2' );
52 is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
58 =head2 new( collation => $collation );
60 Creates a new relationship store for the given collation.
66 isa => 'Text::Tradition::Collation',
73 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
74 default => sub { {} },
80 default => sub { Graph->new( undirected => 1 ) },
82 relationships => 'edges',
83 add_reading => 'add_vertex',
84 delete_reading => 'delete_vertex',
88 =head2 equivalence_graph()
90 Returns an equivalence graph of the collation, in which all readings
91 related via a 'colocated' relationship are transformed into a single
92 vertex. Can be used to determine the validity of a new relationship.
96 has 'equivalence_graph' => (
99 default => sub { Graph->new() },
100 writer => '_reset_equivalence',
103 has '_node_equivalences' => (
107 equivalence => 'get',
108 set_equivalence => 'set',
109 remove_equivalence => 'delete',
110 _clear_equivalence => 'clear',
114 has '_equivalence_readings' => (
119 set_eqreadings => 'set',
120 remove_eqreadings => 'delete',
121 _clear_eqreadings => 'clear',
125 around add_reading => sub {
129 $self->equivalence_graph->add_vertex( @_ );
130 $self->set_equivalence( $_[0], $_[0] );
131 $self->set_eqreadings( $_[0], [ $_[0] ] );
135 around delete_reading => sub {
139 $self->_remove_equivalence_node( @_ );
143 =head2 get_relationship
145 Return the relationship object, if any, that exists between two readings.
149 sub get_relationship {
152 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
153 # Dereference the edge arrayref that was passed.
160 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
161 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
163 return $relationship;
166 sub _set_relationship {
167 my( $self, $relationship, @vector ) = @_;
168 $self->graph->add_edge( @vector );
169 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
170 $self->_make_equivalence( @vector ) if $relationship->colocated;
175 Create a new relationship with the given options and return it.
176 Warn and return undef if the relationship cannot be created.
181 my( $self, $options ) = @_;
182 # Check to see if a relationship exists between the two given readings
183 my $source = delete $options->{'orig_a'};
184 my $target = delete $options->{'orig_b'};
185 my $rel = $self->get_relationship( $source, $target );
187 if( $rel->type eq 'collated' ) {
188 # Always replace a 'collated' relationship with a more descriptive
190 $self->del_relationship( $source, $target );
191 } elsif( $rel->type ne $options->{'type'} ) {
192 throw( "Another relationship of type " . $rel->type
193 . " already exists between $source and $target" );
199 # Check to see if a nonlocal relationship is defined for the two readings
200 $rel = $self->scoped_relationship( $options->{'reading_a'},
201 $options->{'reading_b'} );
202 if( $rel && $rel->type eq $options->{'type'} ) {
205 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'} ) );
207 $rel = Text::Tradition::Collation::Relationship->new( $options );
208 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
213 =head2 add_scoped_relationship( $rel )
215 Keep track of relationships defined between specific readings that are scoped
216 non-locally. Key on whichever reading occurs first alphabetically.
220 sub add_scoped_relationship {
221 my( $self, $rel ) = @_;
222 my $rdga = $rel->type eq 'orthographic' ? $rel->reading_a : lc( $rel->reading_a );
223 my $rdgb = $rel->type eq 'orthographic' ? $rel->reading_b : lc( $rel->reading_b );
224 my $r = $self->scoped_relationship( $rdga, $rdgb );
226 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
227 $r->type, $rdga, $rdgb );
230 my( $first, $second ) = sort ( $rdga, $rdgb );
231 $self->scopedrels->{$first}->{$second} = $rel;
234 =head2 scoped_relationship( $reading_a, $reading_b )
236 Returns the general (document-level or global) relationship that has been defined
237 between the two reading strings. Returns undef if there is no general relationship.
241 sub scoped_relationship {
242 my( $self, $rdga, $rdgb ) = @_;
243 my( $first, $second ) = sort( $rdga, $rdgb );
244 if( exists $self->scopedrels->{$first}->{$second} ) {
245 return $self->scopedrels->{$first}->{$second};
251 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
253 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
254 for the possible options) between the readings given in $source and $target. Sets
255 up a scoped relationship between $sourcetext and $targettext if the relationship is
258 Returns a status boolean and a list of all reading pairs connected by the call to
266 my $t1 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
267 # Test 1.1: try to equate nodes that are prevented with an intermediate collation
268 ok( $t1, "Parsed test fragment file" );
269 my $c1 = $t1->collation;
270 my $trel = $c1->get_relationship( '9,2', '9,3' );
271 is( ref( $trel ), 'Text::Tradition::Collation::Relationship',
272 "Troublesome relationship exists" );
273 is( $trel->type, 'collated', "Troublesome relationship is a collation" );
275 # Try to make the link we want
277 $c1->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
278 ok( 1, "Added cross-collation relationship as expected" );
279 } catch( Text::Tradition::Error $e ) {
280 ok( 0, "Existing collation blocked equivalence relationship: " . $e->message );
284 $c1->calculate_ranks();
285 ok( 1, "Successfully calculated ranks" );
286 } catch ( Text::Tradition::Error $e ) {
287 ok( 0, "Collation now has a cycle: " . $e->message );
290 # Test 1.2: attempt merge of an identical reading
292 $c1->merge_readings( '9,3', '11,5' );
293 ok( 1, "Successfully merged reading 'pontifex'" );
294 } catch ( Text::Tradition::Error $e ) {
295 ok( 0, "Merge of mergeable readings failed: $e->message" );
299 # Test 1.3: attempt relationship with a meta reading (should fail)
301 $c1->add_relationship( '8,1', '9,2', { 'type' => 'collated' } );
302 ok( 0, "Allowed a meta-reading to be used in a relationship" );
303 } catch ( Text::Tradition::Error $e ) {
304 is( $e->message, 'Cannot set relationship on a meta reading',
305 "Relationship link prevented for a meta reading" );
308 # Test 2.1: try to equate nodes that are prevented with a real intermediate
310 my $t2 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
311 my $c2 = $t2->collation;
312 $c2->add_relationship( '9,2', '9,3', { 'type' => 'lexical' } );
313 my $trel2 = $c2->get_relationship( '9,2', '9,3' );
314 is( ref( $trel2 ), 'Text::Tradition::Collation::Relationship',
315 "Created blocking relationship" );
316 is( $trel2->type, 'lexical', "Blocking relationship is not a collation" );
317 # This time the link ought to fail
319 $c2->add_relationship( '8,6', '10,3', { 'type' => 'orthographic' } );
320 ok( 0, "Added cross-equivalent bad relationship" );
321 } catch ( Text::Tradition::Error $e ) {
322 like( $e->message, qr/witness loop/,
323 "Existing equivalence blocked crossing relationship" );
327 $c2->calculate_ranks();
328 ok( 1, "Successfully calculated ranks" );
329 } catch ( Text::Tradition::Error $e ) {
330 ok( 0, "Collation now has a cycle: " . $e->message );
333 # Test 3.1: make a straightforward pair of transpositions.
334 my $t3 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/lf2.xml' );
335 # Test 1: try to equate nodes that are prevented with an intermediate collation
336 my $c3 = $t3->collation;
338 $c3->add_relationship( '36,4', '38,3', { 'type' => 'transposition' } );
339 ok( 1, "Added straightforward transposition" );
340 } catch ( Text::Tradition::Error $e ) {
341 ok( 0, "Failed to add normal transposition: " . $e->message );
344 $c3->add_relationship( '36,3', '38,2', { 'type' => 'transposition' } );
345 ok( 1, "Added straightforward transposition complement" );
346 } catch ( Text::Tradition::Error $e ) {
347 ok( 0, "Failed to add normal transposition complement: " . $e->message );
350 # Test 3.2: try to make a transposition that could be a parallel.
352 $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
353 ok( 0, "Added bad colocated transposition" );
354 } catch ( Text::Tradition::Error $e ) {
355 like( $e->message, qr/Readings appear to be colocated/,
356 "Prevented bad colocated transposition" );
359 # Test 3.3: make the parallel, and then make the transposition again.
361 $c3->add_relationship( '28,3', '29,3', { 'type' => 'orthographic' } );
362 ok( 1, "Equated identical readings for transposition" );
363 } catch ( Text::Tradition::Error $e ) {
364 ok( 0, "Failed to equate identical readings: " . $e->message );
367 $c3->add_relationship( '28,2', '29,2', { 'type' => 'transposition' } );
368 ok( 1, "Added straightforward transposition complement" );
369 } catch ( Text::Tradition::Error $e ) {
370 ok( 0, "Failed to add normal transposition complement: " . $e->message );
377 sub add_relationship {
378 my( $self, $source, $target, $options ) = @_;
379 my $c = $self->collation;
380 my $sourceobj = $c->reading( $source );
381 my $targetobj = $c->reading( $target );
382 throw( "Adding self relationship at $source" ) if $source eq $target;
383 throw( "Cannot set relationship on a meta reading" )
384 if( $sourceobj->is_meta || $targetobj->is_meta );
387 my $droppedcolls = [];
388 if( ref( $options ) eq 'Text::Tradition::Collation::Relationship' ) {
389 $relationship = $options;
390 $thispaironly = 1; # If existing rel, set only where asked.
393 $options->{'scope'} = 'local' unless $options->{'scope'};
394 $options->{'scope'} = 'local' if $options->{'type'} eq 'collated';
395 $options->{'scope'} = 'local' if $options->{'type'} eq 'transposition';
397 my( $is_valid, $reason ) = $self->relationship_valid( $source, $target,
398 $options->{'type'}, $droppedcolls );
399 unless( $is_valid ) {
400 throw( "Invalid relationship: $reason" );
403 # Try to create the relationship object.
404 $options->{'reading_a'} = $sourceobj->text;
405 $options->{'reading_b'} = $targetobj->text;
406 $options->{'orig_a'} = $source;
407 $options->{'orig_b'} = $target;
408 if( $options->{'scope'} ne 'local' ) {
409 # Is there a relationship with this a & b already?
410 # Case-insensitive for non-orthographics.
411 my $rdga = $options->{'type'} eq 'orthographic'
412 ? $options->{'reading_a'} : lc( $options->{'reading_a'} );
413 my $rdgb = $options->{'type'} eq 'orthographic'
414 ? $options->{'reading_b'} : lc( $options->{'reading_b'} );
415 my $otherrel = $self->scoped_relationship( $rdga, $rdgb );
416 if( $otherrel && $otherrel->type eq $options->{type}
417 && $otherrel->scope eq $options->{scope} ) {
418 warn "Applying existing scoped relationship";
419 $relationship = $otherrel;
422 $relationship = $self->create( $options ) unless $relationship; # Will throw on error
426 # Find all the pairs for which we need to set the relationship.
428 if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
429 push( @vectors, $self->_find_applicable( $relationship ) );
432 # Now set the relationship(s).
434 my $rel = $self->get_relationship( $source, $target );
436 if( $rel && $rel ne $relationship ) {
437 if( $rel->nonlocal ) {
438 throw( "Found conflicting relationship at $source - $target" );
439 } elsif( $rel->type ne 'collated' ) {
440 # Replace a collation relationship; leave any other sort in place.
441 my $r1ann = $rel->has_annotation ? $rel->annotation : '';
442 my $r2ann = $relationship->has_annotation ? $relationship->annotation : '';
443 unless( $rel->type eq $relationship->type && $r1ann eq $r2ann ) {
444 warn sprintf( "Not overriding local relationship %s with global %s "
445 . "set at %s -> %s (%s -> %s)", $rel->type, $relationship->type,
446 $source, $target, $rel->reading_a, $rel->reading_b );
451 $self->_set_relationship( $relationship, $source, $target ) unless $skip;
452 push( @pairs_set, [ $source, $target ] );
454 # Set any additional relationships that might be in @vectors.
455 foreach my $v ( @vectors ) {
456 next if $v->[0] eq $source && $v->[1] eq $target;
457 next if $v->[1] eq $source && $v->[0] eq $target;
458 my @added = $self->add_relationship( @$v, $relationship );
459 push( @pairs_set, @added );
462 # Finally, restore whatever collations we can, and return.
463 $self->_restore_collations( @$droppedcolls );
467 =head2 del_scoped_relationship( $reading_a, $reading_b )
469 Returns the general (document-level or global) relationship that has been defined
470 between the two reading strings. Returns undef if there is no general relationship.
474 sub del_scoped_relationship {
475 my( $self, $rdga, $rdgb ) = @_;
476 my( $first, $second ) = sort( $rdga, $rdgb );
477 return delete $self->scopedrels->{$first}->{$second};
480 sub _find_applicable {
481 my( $self, $rel ) = @_;
482 my $c = $self->collation;
483 # TODO Someday we might use a case sensitive language.
484 my $lang = $c->tradition->language;
486 my @identical_readings;
487 if( $rel->type eq 'orthographic' ) {
488 @identical_readings = grep { $_->text eq $rel->reading_a }
491 @identical_readings = grep { lc( $_->text ) eq lc( $rel->reading_a ) }
494 foreach my $ir ( @identical_readings ) {
496 if( $rel->type eq 'orthographic' ) {
497 @itarget = grep { $_->rank == $ir->rank
498 && $_->text eq $rel->reading_b } $c->readings;
500 @itarget = grep { $_->rank == $ir->rank
501 && lc( $_->text ) eq lc( $rel->reading_b ) } $c->readings;
504 # Warn if there is more than one hit with no orth link between them.
505 my $itmain = shift @itarget;
508 map { $all_targets{$_} = 1 } @itarget;
509 map { delete $all_targets{$_} }
510 $self->related_readings( $itmain,
511 sub { $_[0]->type eq 'orthographic' } );
512 warn "More than one unrelated reading with text " . $itmain->text
513 . " at rank " . $ir->rank . "!" if keys %all_targets;
515 push( @vectors, [ $ir->id, $itmain->id ] );
521 =head2 del_relationship( $source, $target )
523 Removes the relationship between the given readings. If the relationship is
524 non-local, removes the relationship everywhere in the graph.
528 sub del_relationship {
529 my( $self, $source, $target ) = @_;
530 my $rel = $self->get_relationship( $source, $target );
531 return () unless $rel; # Nothing to delete; return an empty set.
532 my $colo = $rel->colocated;
533 my @vectors = ( [ $source, $target ] );
534 $self->_remove_relationship( $colo, $source, $target );
535 if( $rel->nonlocal ) {
536 # Remove the relationship wherever it occurs.
537 # Remove the relationship wherever it occurs.
538 my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
539 $self->relationships;
540 foreach my $re ( @rel_edges ) {
541 $self->_remove_relationship( $colo, @$re );
542 push( @vectors, $re );
544 $self->del_scoped_relationship( $rel->reading_a, $rel->reading_b );
549 sub _remove_relationship {
550 my( $self, $equiv, @vector ) = @_;
551 $self->graph->delete_edge( @vector );
552 $self->_break_equivalence( @vector ) if $equiv;
555 =head2 relationship_valid( $source, $target, $type )
557 Checks whether a relationship of type $type may exist between the readings given
558 in $source and $target. Returns a tuple of ( status, message ) where status is
559 a yes/no boolean and, if the answer is no, message gives the reason why.
563 sub relationship_valid {
564 my( $self, $source, $target, $rel, $mustdrop ) = @_;
565 $mustdrop = [] unless $mustdrop; # in case we were passed nothing
566 my $c = $self->collation;
567 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
568 # Check that the two readings do (for a repetition) or do not (for
569 # a transposition) appear in the same witness.
570 # TODO this might be called before witness paths are set...
572 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
573 foreach my $w ( $c->reading_witnesses( $target ) ) {
574 if( $seen_wits{$w} ) {
575 return ( 0, "Readings both occur in witness $w" )
576 if $rel eq 'transposition';
577 return ( 1, "ok" ) if $rel eq 'repetition';
580 return ( 0, "Readings occur only in distinct witnesses" )
581 if $rel eq 'repetition';
583 if ( $rel eq 'transposition' ) {
584 # We also need to check both that the readings occur in distinct
585 # witnesses, and that they are not in the same place. That is,
586 # proposing to link them should cause a witness loop.
587 if( $self->test_equivalence( $source, $target ) ) {
588 return ( 0, "Readings appear to be colocated, not transposed" );
593 } elsif( $rel ne 'repetition' ) {
594 # Check that linking the source and target in a relationship won't lead
595 # to a path loop for any witness.
596 # First, drop/stash any collations that might interfere
597 my $sourceobj = $c->reading( $source );
598 my $targetobj = $c->reading( $target );
599 my $sourcerank = $sourceobj->has_rank ? $sourceobj->rank : -1;
600 my $targetrank = $targetobj->has_rank ? $targetobj->rank : -1;
601 unless( $rel eq 'collated' || $sourcerank == $targetrank ) {
602 push( @$mustdrop, $self->_drop_collations( $source ) );
603 push( @$mustdrop, $self->_drop_collations( $target ) );
604 if( $c->end->has_rank ) {
605 foreach my $rk ( $sourcerank .. $targetrank ) {
606 map { push( @$mustdrop, $self->_drop_collations( $_->id ) ) }
607 $c->readings_at_rank( $rk );
611 unless( $self->test_equivalence( $source, $target ) ) {
612 $self->_restore_collations( @$mustdrop );
613 return( 0, "Relationship would create witness loop" );
619 sub _drop_collations {
620 my( $self, $reading ) = @_;
622 foreach my $n ( $self->graph->neighbors( $reading ) ) {
623 if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
624 push( @dropped, [ $reading, $n ] );
625 $self->del_relationship( $reading, $n );
626 #print STDERR "Dropped collation $reading -> $n\n";
632 sub _restore_collations {
633 my( $self, @vectors ) = @_;
634 foreach my $v ( @vectors ) {
636 $self->add_relationship( @$v, { 'type' => 'collated' } );
637 #print STDERR "Restored collation @$v\n";
639 print STDERR $v->[0] . " - " . $v->[1] . " no longer collate\n";
644 =head2 filter_collations()
646 Utility function. Removes any redundant 'collated' relationships from the graph.
647 A collated relationship is redundant if the readings in question would occupy
648 the same rank regardless of the existence of the relationship.
652 sub filter_collations {
654 my $c = $self->collation;
655 foreach my $r ( 1 .. $c->end->rank - 1 ) {
658 foreach my $rdg ( $c->readings_at_rank( $r ) ) {
659 next if $rdg->is_meta;
661 foreach my $pred ( $rdg->predecessors ) {
662 if( $pred->rank == $r - 1 ) {
664 $anchor = $rdg unless( $anchor );
668 push( @need_collations, $rdg ) unless $ip;
669 $c->relations->_drop_collations( "$rdg" );
672 ? map { $c->add_relationship( $anchor, $_, { 'type' => 'collated' } )
673 unless $c->get_relationship( $anchor, $_ ) } @need_collations
674 : warn "No anchor found at $r";
678 =head2 related_readings( $reading, $filter )
680 Returns a list of readings that are connected via relationship links to $reading.
681 If $filter is set to a subroutine ref, returns only those related readings where
682 $filter( $relationship ) returns a true value.
686 sub related_readings {
687 my( $self, $reading, $filter ) = @_;
689 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
690 $reading = $reading->id;
696 if( $filter eq 'colocated' ) {
697 $filter = sub { $_[0]->colocated };
699 my %found = ( $reading => 1 );
700 my $check = [ $reading ];
704 foreach my $r ( @$check ) {
705 foreach my $nr ( $self->graph->neighbors( $r ) ) {
706 if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
707 push( @$more, $nr ) unless exists $found{$nr};
714 delete $found{$reading};
715 @answer = keys %found;
717 @answer = $self->graph->all_reachable( $reading );
719 if( $return_object ) {
720 my $c = $self->collation;
721 return map { $c->reading( $_ ) } @answer;
727 =head2 merge_readings( $kept, $deleted );
729 Makes a best-effort merge of the relationship links between the given readings, and
730 stops tracking the to-be-deleted reading.
735 my( $self, $kept, $deleted, $combined ) = @_;
736 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
737 # Get the pair of kept / rel
738 my @vector = ( $kept );
739 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
740 next if $vector[0] eq $vector[1]; # Don't add a self loop
742 # If kept changes its text, drop the relationship.
745 # If kept / rel already has a relationship, just keep the old
746 my $rel = $self->get_relationship( @vector );
749 # Otherwise, adopt the relationship that would be deleted.
750 $rel = $self->get_relationship( @$edge );
751 $self->_set_relationship( $rel, @vector );
753 $self->_make_equivalence( $deleted, $kept );
756 ### Equivalence logic
758 sub _remove_equivalence_node {
759 my( $self, $node ) = @_;
760 my $group = $self->equivalence( $node );
761 my $nodelist = $self->eqreadings( $group );
762 if( @$nodelist == 1 && $nodelist->[0] eq $node ) {
763 print STDERR "Removing equivalence $group for $node\n" if $node eq '451,2';
764 $self->remove_eqreadings( $group );
765 } elsif( @$nodelist == 1 ) {
766 warn "DATA INCONSISTENCY in equivalence graph: " . $nodelist->[0] .
767 " in group that should have only $node";
769 print STDERR "Removing $node from equivalence $group\n" if $node eq '451,2';
770 my @newlist = grep { $_ ne $node } @$nodelist;
771 $self->set_eqreadings( $group, \@newlist );
772 $self->remove_equivalence( $node );
776 =head2 add_equivalence_edge
778 Add an edge in the equivalence graph corresponding to $source -> $target in the
779 collation. Should only be called by Collation.
783 sub add_equivalence_edge {
784 my( $self, $source, $target ) = @_;
785 my $seq = $self->equivalence( $source );
786 my $teq = $self->equivalence( $target );
787 $self->equivalence_graph->add_edge( $seq, $teq );
790 =head2 delete_equivalence_edge
792 Remove an edge in the equivalence graph corresponding to $source -> $target in the
793 collation. Should only be called by Collation.
797 sub delete_equivalence_edge {
798 my( $self, $source, $target ) = @_;
799 my $seq = $self->equivalence( $source );
800 my $teq = $self->equivalence( $target );
801 print STDERR "Deleting equivalence edge $seq -> $teq for $source -> $target\n"
802 if grep { $_ eq '451,2' } @_;
803 $self->equivalence_graph->delete_edge( $seq, $teq );
806 sub _is_disconnected {
808 return( scalar $self->equivalence_graph->predecessorless_vertices > 1
809 || scalar $self->equivalence_graph->successorless_vertices > 1 );
812 # Equate two readings in the equivalence graph
813 sub _make_equivalence {
814 my( $self, $source, $target ) = @_;
815 # Get the source equivalent readings
816 my $seq = $self->equivalence( $source );
817 my $teq = $self->equivalence( $target );
818 # Nothing to do if they are already equivalent...
819 return if $seq eq $teq;
820 print STDERR "Making equivalence for $source -> $target\n"
821 if grep { $_ eq '451,2' } @_;
822 my $sourcepool = $self->eqreadings( $seq );
823 # and add them to the target readings.
824 print STDERR "Moving readings '@$sourcepool' from group $seq to $teq\n"
825 if grep { $_ eq '451,2' } @_;
826 push( @{$self->eqreadings( $teq )}, @$sourcepool );
827 map { $self->set_equivalence( $_, $teq ) } @$sourcepool;
828 # Then merge the nodes in the equivalence graph.
829 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
830 $self->equivalence_graph->add_edge( $pred, $teq );
832 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
833 $self->equivalence_graph->add_edge( $teq, $succ );
835 $self->equivalence_graph->delete_vertex( $seq );
836 # TODO enable this after collation parsing is done
837 # throw( "Graph got disconnected making $source / $target equivalence" )
838 # if $self->_is_disconnected;
841 =head2 test_equivalence
843 Test whether, if two readings were equated with a 'colocated' relationship,
844 the graph would still be valid.
848 sub test_equivalence {
849 my( $self, $source, $target ) = @_;
850 # Try merging the nodes in the equivalence graph; return a true value if
851 # no cycle is introduced thereby. Restore the original graph first.
853 # Keep track of edges we add
856 # Get the reading equivalents
857 my $seq = $self->equivalence( $source );
858 my $teq = $self->equivalence( $target );
859 # Maybe this is easy?
860 return 1 if $seq eq $teq;
862 # Save the first graph
863 my $checkstr = $self->equivalence_graph->stringify();
864 # Add and save relevant edges
865 foreach my $pred ( $self->equivalence_graph->predecessors( $seq ) ) {
866 if( $self->equivalence_graph->has_edge( $pred, $teq ) ) {
867 $added_pred{$pred} = 0;
869 $self->equivalence_graph->add_edge( $pred, $teq );
870 $added_pred{$pred} = 1;
873 foreach my $succ ( $self->equivalence_graph->successors( $seq ) ) {
874 if( $self->equivalence_graph->has_edge( $teq, $succ ) ) {
875 $added_succ{$succ} = 0;
877 $self->equivalence_graph->add_edge( $teq, $succ );
878 $added_succ{$succ} = 1;
881 # Delete source equivalent and test
882 $self->equivalence_graph->delete_vertex( $seq );
883 my $ret = !$self->equivalence_graph->has_a_cycle;
885 # Restore what we changed
886 $self->equivalence_graph->add_vertex( $seq );
887 foreach my $pred ( keys %added_pred ) {
888 $self->equivalence_graph->add_edge( $pred, $seq );
889 $self->equivalence_graph->delete_edge( $pred, $teq ) if $added_pred{$pred};
891 foreach my $succ ( keys %added_succ ) {
892 $self->equivalence_graph->add_edge( $seq, $succ );
893 $self->equivalence_graph->delete_edge( $teq, $succ ) if $added_succ{$succ};
895 unless( $self->equivalence_graph->eq( $checkstr ) ) {
896 warn "GRAPH CHANGED after testing";
902 # Unmake an equivalence link between two readings. Should only be called internally.
903 sub _break_equivalence {
904 my( $self, $source, $target ) = @_;
906 # This is the hard one. Need to reconstruct the equivalence groups without
909 map { $sng{$_} = 1 } $self->_find_equiv_without( $source, $target );
910 map { $tng{$_} = 1 } $self->_find_equiv_without( $target, $source );
911 # If these groups intersect, they are still connected; do nothing.
912 foreach my $el ( keys %tng ) {
913 if( exists $sng{$el} ) {
914 print STDERR "Equivalence break $source / $target is a noop\n"
915 if grep { $_ eq '451,2' } @_;
919 print STDERR "Breaking equivalence $source / $target\n"
920 if grep { $_ eq '451,2' } @_;
921 # If they don't intersect, then we split the nodes in the graph and in
922 # the hashes. First figure out which group has which name
923 my $oldgroup = $self->equivalence( $source ); # same as $target
924 my $keepsource = $sng{$oldgroup};
925 my $newgroup = $keepsource ? $target : $source;
926 my( $oldmembers, $newmembers );
928 $oldmembers = [ keys %sng ];
929 $newmembers = [ keys %tng ];
931 $oldmembers = [ keys %tng ];
932 $newmembers = [ keys %sng ];
935 # First alter the old group in the hash
936 $self->set_eqreadings( $oldgroup, $oldmembers );
937 foreach my $el ( @$oldmembers ) {
938 $self->set_equivalence( $el, $oldgroup );
941 # then add the new group back to the hash with its new key
942 $self->set_eqreadings( $newgroup, $newmembers );
943 foreach my $el ( @$newmembers ) {
944 $self->set_equivalence( $el, $newgroup );
947 # Now add the new group back to the equivalence graph
948 $self->equivalence_graph->add_vertex( $newgroup );
949 # ...add the appropriate edges to the source group vertext
950 my $c = $self->collation;
951 foreach my $rdg ( @$newmembers ) {
952 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
953 $self->equivalence_graph->add_edge( $self->equivalence( $rp ), $newgroup );
955 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
956 $self->equivalence_graph->add_edge( $newgroup, $self->equivalence( $rs ) );
960 # ...and figure out which edges on the old group vertex to delete.
961 my( %old_pred, %old_succ );
962 foreach my $rdg ( @$oldmembers ) {
963 foreach my $rp ( $c->sequence->predecessors( $rdg ) ) {
964 $old_pred{$self->equivalence( $rp )} = 1;
966 foreach my $rs ( $c->sequence->successors( $rdg ) ) {
967 $old_succ{$self->equivalence( $rs )} = 1;
970 foreach my $p ( $self->equivalence_graph->predecessors( $oldgroup ) ) {
971 unless( $old_pred{$p} ) {
972 $self->equivalence_graph->delete_edge( $p, $oldgroup );
975 foreach my $s ( $self->equivalence_graph->successors( $oldgroup ) ) {
976 unless( $old_succ{$s} ) {
977 $self->equivalence_graph->delete_edge( $oldgroup, $s );
980 # TODO enable this after collation parsing is done
981 # throw( "Graph got disconnected breaking $source / $target equivalence" )
982 # if $self->_is_disconnected;
985 sub _find_equiv_without {
986 my( $self, $first, $second ) = @_;
987 my %found = ( $first => 1 );
988 my $check = [ $first ];
992 foreach my $r ( @$check ) {
993 foreach my $nr ( $self->graph->neighbors( $r ) ) {
994 next if $r eq $second;
995 if( $self->get_relationship( $r, $nr )->colocated ) {
996 push( @$more, $nr ) unless exists $found{$nr};
1006 =head2 rebuild_equivalence
1008 (Re)build the equivalence graph from scratch. Dumps the graph, makes a new one,
1009 adds all readings and edges, then makes an equivalence for all relationships.
1013 sub rebuild_equivalence {
1015 my $newgraph = Graph->new();
1016 # Set this as the new equivalence graph
1017 $self->_reset_equivalence( $newgraph );
1018 # Clear out the data hashes
1019 $self->_clear_equivalence;
1020 $self->_clear_eqreadings;
1023 foreach my $r ( $self->collation->readings ) {
1025 $newgraph->add_vertex( $rid );
1026 $self->set_equivalence( $rid, $rid );
1027 $self->set_eqreadings( $rid, [ $rid ] );
1031 foreach my $e ( $self->collation->paths ) {
1032 $self->add_equivalence_edge( @$e );
1035 # Now equate the colocated readings. This does no testing;
1036 # it assumes that all preexisting relationships are valid.
1037 foreach my $rel ( $self->relationships ) {
1038 my $relobj = $self->get_relationship( $rel );
1039 next unless $relobj && $relobj->colocated;
1040 $self->_make_equivalence( @$rel );
1047 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
1049 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1050 $rgraph->setAttribute( 'edgedefault', 'directed' );
1051 $rgraph->setAttribute( 'id', 'relationships', );
1052 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
1053 $rgraph->setAttribute( 'parse.edges', 0 );
1054 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
1055 $rgraph->setAttribute( 'parse.nodes', 0 );
1056 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
1058 # Add the vertices according to their XML IDs
1059 my %rdg_lookup = ( reverse %$node_hash );
1060 # my @nlist = sort _by_xmlid keys( %rdg_lookup ); ## CAUSES SEGFAULT
1061 my @nlist = sort keys( %rdg_lookup );
1062 foreach my $n ( @nlist ) {
1063 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
1064 $n_el->setAttribute( 'id', $n );
1065 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
1067 $rgraph->setAttribute( 'parse.nodes', scalar @nlist );
1069 # Add the relationship edges, with their object information
1071 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
1072 # Add an edge and fill in its relationship info.
1073 next unless( exists $node_hash->{$e->[0]} && exists $node_hash->{$e->[1]} );
1074 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
1075 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
1076 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
1077 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
1079 my $rel_obj = $self->get_relationship( @$e );
1080 foreach my $key ( keys %$edge_keys ) {
1081 my $value = $rel_obj->$key;
1082 _add_graphml_data( $edge_el, $edge_keys->{$key}, $value )
1086 $rgraph->setAttribute( 'parse.edges', $edge_ctr );
1094 return $tmp_a <=> $tmp_b;
1097 sub _add_graphml_data {
1098 my( $el, $key, $value ) = @_;
1099 return unless defined $value;
1100 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1101 $data_el->setAttribute( 'key', $key );
1102 $data_el->appendText( $value );
1106 Text::Tradition::Error->throw(
1107 'ident' => 'Relationship error',
1113 __PACKAGE__->meta->make_immutable;