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.
27 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
33 =head2 new( collation => $collation );
35 Creates a new relationship store for the given collation.
41 isa => 'Text::Tradition::Collation',
48 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
49 default => sub { {} },
55 default => sub { Graph->new( undirected => 1 ) },
57 relationships => 'edges',
58 add_reading => 'add_vertex',
59 delete_reading => 'delete_vertex',
60 delete_relationship => 'delete_edge',
64 around 'delete_relationship' => sub {
68 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
69 # Dereference the edge arrayref that was passed.
75 return $self->$orig( @vector );
78 =head2 get_relationship
80 Return the relationship object, if any, that exists between two readings.
84 sub get_relationship {
87 if( @_ == 1 && ref( $_[0] ) eq 'ARRAY' ) {
88 # Dereference the edge arrayref that was passed.
95 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
96 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
101 sub _set_relationship {
102 my( $self, $relationship, @vector ) = @_;
103 $self->graph->add_edge( @vector );
104 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
107 sub _remove_relationship {
108 my( $self, @vector ) = @_;
109 $self->graph->delete_edge( @vector );
114 Create a new relationship with the given options and return it.
115 Warn and return undef if the relationship cannot be created.
120 my( $self, $options ) = @_;
121 # Check to see if a relationship exists between the two given readings
122 my $source = delete $options->{'orig_a'};
123 my $target = delete $options->{'orig_b'};
124 my $rel = $self->get_relationship( $source, $target );
126 if( $rel->type ne $options->{'type'} ) {
127 throw( "Another relationship of type " . $rel->type
128 . " already exists between $source and $target" );
134 # Check to see if a nonlocal relationship is defined for the two readings
135 $rel = $self->scoped_relationship( $options->{'reading_a'},
136 $options->{'reading_b'} );
137 if( $rel && $rel->type eq $options->{'type'} ) {
140 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'} ) );
142 $rel = Text::Tradition::Collation::Relationship->new( $options );
143 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
148 =head2 add_scoped_relationship( $rel )
150 Keep track of relationships defined between specific readings that are scoped
151 non-locally. Key on whichever reading occurs first alphabetically.
155 sub add_scoped_relationship {
156 my( $self, $rel ) = @_;
157 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
159 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
160 $r->type, $rel->reading_a, $rel->reading_b );
163 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
166 =head2 scoped_relationship( $reading_a, $reading_b )
168 Returns the general (document-level or global) relationship that has been defined
169 between the two reading strings. Returns undef if there is no general relationship.
173 sub scoped_relationship {
174 my( $self, $rdga, $rdgb ) = @_;
175 my( $first, $second ) = sort( $rdga, $rdgb );
176 if( exists $self->scopedrels->{$first}->{$second} ) {
177 return $self->scopedrels->{$first}->{$second};
183 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
185 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
186 for the possible options) between the readings given in $source and $target. Sets
187 up a scoped relationship between $sourcetext and $targettext if the relationship is
190 Returns a status boolean and a list of all reading pairs connected by the call to
195 sub add_relationship {
196 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
199 $options->{'scope'} = 'local' unless $options->{'scope'};
201 my( $is_valid, $reason ) =
202 $self->relationship_valid( $source, $target, $options->{'type'} );
203 unless( $is_valid ) {
204 throw( "Invalid relationship: $reason" );
207 # Try to create the relationship object.
208 $options->{'reading_a'} = $source_rdg->text;
209 $options->{'reading_b'} = $target_rdg->text;
210 $options->{'orig_a'} = $source;
211 $options->{'orig_b'} = $target;
212 my $relationship = $self->create( $options ); # Will throw on error
214 # Find all the pairs for which we need to set the relationship.
215 my @vectors = ( [ $source, $target ] );
216 if( $relationship->colocated && $relationship->nonlocal ) {
217 my $c = $self->collation;
218 # Set the same relationship everywhere we can, throughout the graph.
219 my @identical_readings = grep { $_->text eq $relationship->reading_a }
221 foreach my $ir ( @identical_readings ) {
222 next if $ir->id eq $source;
223 # Check to see if there is a target reading with the same text at
226 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
230 warn "More than one reading with text " . $target_rdg->text
231 . " at rank " . $ir->rank . "!" if @itarget > 1;
232 push( @vectors, [ $ir->id, $itarget[0]->id ] );
237 # Now set the relationship(s).
239 foreach my $v ( @vectors ) {
240 my $rel = $self->get_relationship( @$v );
242 if( $rel->nonlocal ) {
243 throw( "Found conflicting relationship at @$v" );
245 warn "Not overriding local relationship set at @$v";
249 $self->_set_relationship( $relationship, @$v );
250 push( @pairs_set, $v );
256 =head2 relationship_valid( $source, $target, $type )
258 Checks whether a relationship of type $type may exist between the readings given
259 in $source and $target. Returns a tuple of ( status, message ) where status is
260 a yes/no boolean and, if the answer is no, message gives the reason why.
264 sub relationship_valid {
265 my( $self, $source, $target, $rel ) = @_;
266 my $c = $self->collation;
267 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
268 # Check that the two readings do (for a repetition) or do not (for
269 # a transposition) appear in the same witness.
271 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
272 foreach my $w ( $c->reading_witnesses( $target ) ) {
273 if( $seen_wits{$w} ) {
274 return ( 0, "Readings both occur in witness $w" )
275 if $rel eq 'transposition';
276 return ( 1, "ok" ) if $rel eq 'repetition';
278 return $rel eq 'transposition' ? ( 1, "ok" )
279 : ( 0, "Readings occur only in distinct witnesses" );
282 # Check that linking the source and target in a relationship won't lead
283 # to a path loop for any witness. If they have the same rank then fine.
285 if $c->reading( $source )->has_rank
286 && $c->reading( $target )->has_rank
287 && $c->reading( $source )->rank == $c->reading( $target )->rank;
289 # Otherwise, first make a lookup table of all the
290 # readings related to either the source or the target.
291 my @proposed_related = ( $source, $target );
292 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
293 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
295 map { $pr_ids{ $_ } = 1 } @proposed_related;
297 # The cumulative predecessors and successors of the proposed-related readings
298 # should not overlap.
301 foreach my $pr ( keys %pr_ids ) {
302 map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
303 map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
305 foreach my $k ( keys %all_pred ) {
306 return( 0, "Relationship would create witness loop" )
307 if exists $all_succ{$k};
309 foreach my $k ( keys %pr_ids ) {
310 return( 0, "Relationship would create witness loop" )
311 if exists $all_pred{$k} || exists $all_succ{$k};
317 =head2 related_readings( $reading, $colocated_only )
319 Returns a list of readings that are connected via relationship links to $reading.
320 If $colocated_only is true, restricts the list to those readings that are in the
321 same logical location (and therefore have the same rank in the collation graph.)
325 sub related_readings {
326 my( $self, $reading, $colocated ) = @_;
328 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
329 $reading = $reading->id;
334 my %found = ( $reading => 1 );
335 my $check = [ $reading ];
339 foreach my $r ( @$check ) {
340 foreach my $nr ( $self->graph->neighbors( $r ) ) {
341 if( $self->get_relationship( $r, $nr )->colocated ) {
342 push( @$more, $nr ) unless exists $found{$nr};
349 @answer = keys %found;
351 @answer = $self->graph->all_reachable( $reading );
353 if( $return_object ) {
354 my $c = $self->collation;
355 return map { $c->reading( $_ ) } @answer;
361 =head2 merge_readings( $kept, $deleted );
363 Makes a best-effort merge of the relationship links between the given readings, and
364 stops tracking the to-be-deleted reading.
369 my( $self, $kept, $deleted, $combined ) = @_;
370 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
371 # Get the pair of kept / rel
372 my @vector = ( $kept );
373 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
374 next if $vector[0] eq $vector[1]; # Don't add a self loop
376 # If kept changes its text, drop the relationship.
379 # If kept / rel already has a relationship, warn and keep the old
380 my $rel = $self->get_relationship( @vector );
382 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
386 # Otherwise, adopt the relationship that would be deleted.
387 $rel = $self->get_relationship( @$edge );
388 $self->_set_relationship( $rel, @vector );
390 $self->delete_reading( $deleted );
394 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
396 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
397 $rgraph->setAttribute( 'edgedefault', 'directed' );
398 $rgraph->setAttribute( 'id', 'relationships', );
399 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
400 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
401 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
402 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
403 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
405 # Add the vertices according to their XML IDs
406 my %rdg_lookup = ( reverse %$node_hash );
407 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
408 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
409 $n_el->setAttribute( 'id', $n );
410 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
413 # Add the relationship edges, with their object information
415 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
416 # Add an edge and fill in its relationship info.
417 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
418 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
419 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
420 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
422 my $rel_obj = $self->get_relationship( @$e );
423 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
424 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
425 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
426 $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
427 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
428 $rel_obj->non_independent ) if $rel_obj->nonind_set;
437 return $tmp_a <=> $tmp_b;
440 sub _add_graphml_data {
441 my( $el, $key, $value ) = @_;
442 return unless defined $value;
443 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
444 $data_el->setAttribute( 'key', $key );
445 $data_el->appendText( $value );
449 Text::Tradition::Error->throw(
450 'ident' => 'Relationship error',
456 __PACKAGE__->meta->make_immutable;