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' => 'meaning' } );
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( 'n9', '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( 'n8', 'n13' );
50 is( scalar @v2, 2, "Deleted second global relationship" );
52 my @v3 = $c->del_relationship( 'n1', 'n2' );
53 ok( 0, "Should have errored on non-existent relationship" );
54 } catch( Text::Tradition::Error $e ) {
55 like( $e->message, qr/No relationship defined/, "Attempt to delete non-existent relationship errored" );
62 =head2 new( collation => $collation );
64 Creates a new relationship store for the given collation.
70 isa => 'Text::Tradition::Collation',
77 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
78 default => sub { {} },
84 default => sub { Graph->new( undirected => 1 ) },
86 relationships => 'edges',
87 add_reading => 'add_vertex',
88 delete_reading => 'delete_vertex',
89 delete_relationship => 'delete_edge',
93 around 'delete_relationship' => sub {
97 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
98 # Dereference the edge arrayref that was passed.
104 return $self->$orig( @vector );
107 =head2 get_relationship
109 Return the relationship object, if any, that exists between two readings.
113 sub get_relationship {
116 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
117 # Dereference the edge arrayref that was passed.
124 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
125 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
127 return $relationship;
130 sub _set_relationship {
131 my( $self, $relationship, @vector ) = @_;
132 $self->graph->add_edge( @vector );
133 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
136 sub _remove_relationship {
137 my( $self, @vector ) = @_;
138 $self->graph->delete_edge( @vector );
143 Create a new relationship with the given options and return it.
144 Warn and return undef if the relationship cannot be created.
149 my( $self, $options ) = @_;
150 # Check to see if a relationship exists between the two given readings
151 my $source = delete $options->{'orig_a'};
152 my $target = delete $options->{'orig_b'};
153 my $rel = $self->get_relationship( $source, $target );
155 if( $rel->type eq 'collated' ) {
156 # Always replace a 'collated' relationship with a more descriptive
158 $self->del_relationship( $source, $target );
159 } elsif( $rel->type ne $options->{'type'} ) {
160 throw( "Another relationship of type " . $rel->type
161 . " already exists between $source and $target" );
167 # Check to see if a nonlocal relationship is defined for the two readings
168 $rel = $self->scoped_relationship( $options->{'reading_a'},
169 $options->{'reading_b'} );
170 if( $rel && $rel->type eq $options->{'type'} ) {
173 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'} ) );
175 $rel = Text::Tradition::Collation::Relationship->new( $options );
176 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
181 =head2 add_scoped_relationship( $rel )
183 Keep track of relationships defined between specific readings that are scoped
184 non-locally. Key on whichever reading occurs first alphabetically.
188 sub add_scoped_relationship {
189 my( $self, $rel ) = @_;
190 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
192 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
193 $r->type, $rel->reading_a, $rel->reading_b );
196 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
199 =head2 scoped_relationship( $reading_a, $reading_b )
201 Returns the general (document-level or global) relationship that has been defined
202 between the two reading strings. Returns undef if there is no general relationship.
206 sub scoped_relationship {
207 my( $self, $rdga, $rdgb ) = @_;
208 my( $first, $second ) = sort( $rdga, $rdgb );
209 if( exists $self->scopedrels->{$first}->{$second} ) {
210 return $self->scopedrels->{$first}->{$second};
216 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
218 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
219 for the possible options) between the readings given in $source and $target. Sets
220 up a scoped relationship between $sourcetext and $targettext if the relationship is
223 Returns a status boolean and a list of all reading pairs connected by the call to
228 sub add_relationship {
229 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
232 $options->{'scope'} = 'local' unless $options->{'scope'};
234 my( $is_valid, $reason ) =
235 $self->relationship_valid( $source, $target, $options->{'type'} );
236 unless( $is_valid ) {
237 throw( "Invalid relationship: $reason" );
240 # Try to create the relationship object.
241 $options->{'reading_a'} = $source_rdg->text;
242 $options->{'reading_b'} = $target_rdg->text;
243 $options->{'orig_a'} = $source;
244 $options->{'orig_b'} = $target;
245 my $relationship = $self->create( $options ); # Will throw on error
247 # Find all the pairs for which we need to set the relationship.
248 my @vectors = ( [ $source, $target ] );
249 if( $relationship->colocated && $relationship->nonlocal ) {
250 my $c = $self->collation;
251 # Set the same relationship everywhere we can, throughout the graph.
252 my @identical_readings = grep { $_->text eq $relationship->reading_a }
254 foreach my $ir ( @identical_readings ) {
255 next if $ir->id eq $source;
256 # Check to see if there is a target reading with the same text at
259 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
263 warn "More than one reading with text " . $target_rdg->text
264 . " at rank " . $ir->rank . "!" if @itarget > 1;
265 push( @vectors, [ $ir->id, $itarget[0]->id ] );
270 # Now set the relationship(s).
272 foreach my $v ( @vectors ) {
273 my $rel = $self->get_relationship( @$v );
275 if( $rel->nonlocal ) {
276 throw( "Found conflicting relationship at @$v" );
278 warn "Not overriding local relationship set at @$v";
282 $self->_set_relationship( $relationship, @$v );
283 push( @pairs_set, $v );
289 =head2 del_relationship( $source, $target )
291 Removes the relationship between the given readings. If the relationship is
292 non-local, removes the relationship everywhere in the graph.
296 sub del_relationship {
297 my( $self, $source, $target ) = @_;
298 my $rel = $self->get_relationship( $source, $target );
299 throw( "No relationship defined between $source and $target" ) unless $rel;
300 my @vectors = ( [ $source, $target ] );
301 $self->_remove_relationship( $source, $target );
302 if( $rel->nonlocal ) {
303 # Remove the relationship wherever it occurs.
304 my @rel_edges = grep { $self->get_relationship( @$_ ) == $rel }
305 $self->relationships;
306 foreach my $re ( @rel_edges ) {
307 $self->_remove_relationship( @$re );
308 push( @vectors, $re );
314 =head2 relationship_valid( $source, $target, $type )
316 Checks whether a relationship of type $type may exist between the readings given
317 in $source and $target. Returns a tuple of ( status, message ) where status is
318 a yes/no boolean and, if the answer is no, message gives the reason why.
322 sub relationship_valid {
323 my( $self, $source, $target, $rel ) = @_;
324 my $c = $self->collation;
325 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
326 # Check that the two readings do (for a repetition) or do not (for
327 # a transposition) appear in the same witness.
328 # TODO this might be called before witness paths are set...
330 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
331 foreach my $w ( $c->reading_witnesses( $target ) ) {
332 if( $seen_wits{$w} ) {
333 return ( 0, "Readings both occur in witness $w" )
334 if $rel eq 'transposition';
335 return ( 1, "ok" ) if $rel eq 'repetition';
337 return $rel eq 'transposition' ? ( 1, "ok" )
338 : ( 0, "Readings occur only in distinct witnesses" );
341 # Check that linking the source and target in a relationship won't lead
342 # to a path loop for any witness. If they have the same rank then fine.
344 if $c->reading( $source )->has_rank
345 && $c->reading( $target )->has_rank
346 && $c->reading( $source )->rank == $c->reading( $target )->rank;
348 # Otherwise, first make a lookup table of all the
349 # readings related to either the source or the target.
350 my @proposed_related = ( $source, $target );
351 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
352 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
354 map { $pr_ids{ $_ } = 1 } @proposed_related;
356 # The cumulative predecessors and successors of the proposed-related readings
357 # should not overlap.
360 foreach my $pr ( keys %pr_ids ) {
361 map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
362 map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
364 foreach my $k ( keys %all_pred ) {
365 return( 0, "Relationship would create witness loop" )
366 if exists $all_succ{$k};
368 foreach my $k ( keys %pr_ids ) {
369 return( 0, "Relationship would create witness loop" )
370 if exists $all_pred{$k} || exists $all_succ{$k};
376 =head2 related_readings( $reading, $filter )
378 Returns a list of readings that are connected via relationship links to $reading.
379 If $filter is set to a subroutine ref, returns only those related readings where
380 $filter( $relationship ) returns a true value.
384 sub related_readings {
385 my( $self, $reading, $filter ) = @_;
387 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
388 $reading = $reading->id;
394 if( $filter eq 'colocated' ) {
395 $filter = sub { $_[0]->colocated };
397 my %found = ( $reading => 1 );
398 my $check = [ $reading ];
402 foreach my $r ( @$check ) {
403 foreach my $nr ( $self->graph->neighbors( $r ) ) {
404 if( &$filter( $self->get_relationship( $r, $nr ) ) ) {
405 push( @$more, $nr ) unless exists $found{$nr};
412 delete $found{$reading};
413 @answer = keys %found;
415 @answer = $self->graph->all_reachable( $reading );
417 if( $return_object ) {
418 my $c = $self->collation;
419 return map { $c->reading( $_ ) } @answer;
425 =head2 merge_readings( $kept, $deleted );
427 Makes a best-effort merge of the relationship links between the given readings, and
428 stops tracking the to-be-deleted reading.
433 my( $self, $kept, $deleted, $combined ) = @_;
434 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
435 # Get the pair of kept / rel
436 my @vector = ( $kept );
437 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
438 next if $vector[0] eq $vector[1]; # Don't add a self loop
440 # If kept changes its text, drop the relationship.
443 # If kept / rel already has a relationship, warn and keep the old
444 my $rel = $self->get_relationship( @vector );
446 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
450 # Otherwise, adopt the relationship that would be deleted.
451 $rel = $self->get_relationship( @$edge );
452 $self->_set_relationship( $rel, @vector );
454 $self->delete_reading( $deleted );
458 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
460 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
461 $rgraph->setAttribute( 'edgedefault', 'directed' );
462 $rgraph->setAttribute( 'id', 'relationships', );
463 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
464 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
465 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
466 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
467 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
469 # Add the vertices according to their XML IDs
470 my %rdg_lookup = ( reverse %$node_hash );
471 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
472 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
473 $n_el->setAttribute( 'id', $n );
474 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
477 # Add the relationship edges, with their object information
479 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
480 # Add an edge and fill in its relationship info.
481 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
482 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
483 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
484 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
486 my $rel_obj = $self->get_relationship( @$e );
487 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
488 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
489 _add_graphml_data( $edge_el, $edge_keys->{'annotation'}, $rel_obj->annotation );
490 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
491 $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
492 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
493 $rel_obj->non_independent ) if $rel_obj->nonind_set;
502 return $tmp_a <=> $tmp_b;
505 sub _add_graphml_data {
506 my( $el, $key, $value ) = @_;
507 return unless defined $value;
508 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
509 $data_el->setAttribute( 'key', $key );
510 $data_el->appendText( $value );
514 Text::Tradition::Error->throw(
515 'ident' => 'Relationship error',
521 __PACKAGE__->meta->make_immutable;