1 package Text::Tradition::Collation::RelationshipStore;
5 use Text::Tradition::Collation::Relationship;
11 Text::Tradition::Collation::RelationshipStore - Keeps track of the relationships
12 between readings in a given collation
16 Text::Tradition is a library for representation and analysis of collated
17 texts, particularly medieval ones. The RelationshipStore is an internal object
18 of the collation, to keep track of the defined relationships (both specific and
19 general) between readings.
25 use_ok( 'Text::Tradition::Collation::RelationshipStore' );
31 =head2 new( collation => $collation );
33 Creates a new relationship store for the given collation.
39 isa => 'Text::Tradition::Collation',
46 isa => 'HashRef[HashRef[Text::Tradition::Collation::Relationship]]',
47 default => sub { {} },
53 default => sub { Graph->new( undirected => 1 ) },
55 relationships => 'edges',
56 add_reading => 'add_vertex',
57 delete_reading => 'delete_vertex',
61 =head2 get_relationship
63 Return the relationship object, if any, that exists between two readings.
67 sub get_relationship {
68 my( $self, @vector ) = @_;
70 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
71 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
76 sub _set_relationship {
77 my( $self, $relationship, @vector ) = @_;
78 $self->graph->add_edge( @vector );
79 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
84 Create a new relationship with the given options and return it.
85 Warn and return undef if the relationship cannot be created.
90 my( $self, $options ) = @_;
91 # Check to see if a relationship exists between the two given readings
92 my $source = delete $options->{'orig_a'};
93 my $target = delete $options->{'orig_b'};
94 my $rel = $self->get_relationship( $source, $target );
96 if( $rel->type ne $options->{'type'} ) {
97 warn "Another relationship of type " . $rel->type
98 . " already exists between $source and $target";
105 # Check to see if a nonlocal relationship is defined for the two readings
106 $rel = $self->scoped_relationship( $options->{'reading_a'},
107 $options->{'reading_b'} );
108 if( $rel && $rel->type eq $options->{'type'} ) {
111 warn 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'} );
114 $rel = Text::Tradition::Collation::Relationship->new( $options );
115 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
120 =head2 add_scoped_relationship( $rel )
122 Keep track of relationships defined between specific readings that are scoped
123 non-locally. Key on whichever reading occurs first alphabetically.
127 sub add_scoped_relationship {
128 my( $self, $rel ) = @_;
129 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
131 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
132 $r->type, $rel->reading_a, $rel->reading_b );
135 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
138 =head2 scoped_relationship( $reading_a, $reading_b )
140 Returns the general (document-level or global) relationship that has been defined
141 between the two reading strings. Returns undef if there is no general relationship.
145 sub scoped_relationship {
146 my( $self, $rdga, $rdgb ) = @_;
147 my( $first, $second ) = sort( $rdga, $rdgb );
148 if( exists $self->scopedrels->{$first}->{$second} ) {
149 return $self->scopedrels->{$first}->{$second};
155 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
157 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
158 for the possible options) between the readings given in $source and $target. Sets
159 up a scoped relationship between $sourcetext and $targettext if the relationship is
162 Returns a status boolean and a list of all reading pairs connected by the call to
167 sub add_relationship {
168 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
171 $options->{'scope'} = 'local' unless $options->{'scope'};
173 my( $is_valid, $reason ) =
174 $self->relationship_valid( $source, $target, $options->{'type'} );
175 unless( $is_valid ) {
176 return ( undef, $reason );
179 # Try to create the relationship object.
180 $options->{'reading_a'} = $source_rdg->text;
181 $options->{'reading_b'} = $target_rdg->text;
182 $options->{'orig_a'} = $source;
183 $options->{'orig_b'} = $target;
184 my $relationship = $self->create( $options );
185 return( undef, "Relationship creation failed" ) unless $relationship;
187 # Find all the pairs for which we need to set the relationship.
188 my @vectors = ( [ $source, $target ] );
189 if( $relationship->colocated && $relationship->nonlocal ) {
190 my $c = $self->collation;
191 # Set the same relationship everywhere we can, throughout the graph.
192 my @identical_readings = grep { $_->text eq $relationship->reading_a }
194 foreach my $ir ( @identical_readings ) {
195 next if $ir->id eq $source;
196 # Check to see if there is a target reading with the same text at
199 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
203 warn "More than one reading with text " . $target_rdg->text
204 . " at rank " . $ir->rank . "!" if @itarget > 1;
205 push( @vectors, [ $ir->id, $itarget[0]->id ] );
210 # Now set the relationship(s).
212 foreach my $v ( @vectors ) {
213 my $rel = $self->get_relationship( @$v );
215 my $warning = $rel->nonlocal
216 ? "Found conflicting relationship at @$v"
217 : "Not overriding local relationship set at @$v";
221 $self->_set_relationship( $relationship, @$v );
222 push( @pairs_set, $v );
225 return( 1, @pairs_set );
228 =head2 relationship_valid( $source, $target, $type )
230 Checks whether a relationship of type $type may exist between the readings given
231 in $source and $target. Returns a tuple of ( status, message ) where status is
232 a yes/no boolean and, if the answer is no, message gives the reason why.
236 sub relationship_valid {
237 my( $self, $source, $target, $rel ) = @_;
238 my $c = $self->collation;
239 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
240 # Check that the two readings do (for a repetition) or do not (for
241 # a transposition) appear in the same witness.
243 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
244 foreach my $w ( $c->reading_witnesses( $target ) ) {
245 if( $seen_wits{$w} ) {
246 return ( 0, "Readings both occur in witness $w" )
247 if $rel eq 'transposition';
248 return ( 1, "ok" ) if $rel eq 'repetition';
250 return $rel eq 'transposition' ? ( 1, "ok" )
251 : ( 0, "Readings occur only in distinct witnesses" );
254 # Check that linking the source and target in a relationship won't lead
255 # to a path loop for any witness. First make a lookup table of all the
256 # readings related to either the source or the target.
257 my @proposed_related = ( $source, $target );
258 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
259 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
261 map { $pr_ids{ $_ } = 1 } @proposed_related;
263 # None of these proposed related readings should have a neighbor that
264 # is also in proposed_related.
265 foreach my $pr ( keys %pr_ids ) {
266 foreach my $neighbor( $c->sequence->neighbors( $pr ) ) {
267 return( 0, "Would relate neighboring readings $pr and $neighbor" )
268 if exists $pr_ids{$neighbor};
275 =head2 related_readings( $reading, $colocated_only )
277 Returns a list of readings that are connected via relationship links to $reading.
278 If $colocated_only is true, restricts the list to those readings that are in the
279 same logical location (and therefore have the same rank in the collation graph.)
283 sub related_readings {
284 my( $self, $reading, $colocated ) = @_;
286 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
287 $reading = $reading->id;
292 my %found = ( $reading => 1 );
293 my $check = [ $reading ];
297 foreach my $r ( @$check ) {
298 foreach my $nr ( $self->graph->neighbors( $r ) ) {
299 if( $self->get_relationship( $r, $nr )->colocated ) {
300 push( @$more, $nr ) unless exists $found{$nr};
307 @answer = keys %found;
309 @answer = $self->graph->all_reachable( $reading );
311 if( $return_object ) {
312 my $c = $self->collation;
313 return map { $c->reading( $_ ) } @answer;
319 =head2 merge_readings( $kept, $deleted );
321 Makes a best-effort merge of the relationship links between the given readings, and
322 stops tracking the to-be-deleted reading.
327 my( $self, $kept, $deleted, $combined ) = @_;
328 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
329 # Get the pair of kept / rel
330 my @vector = ( $kept );
331 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
332 next if $vector[0] eq $vector[1]; # Don't add a self loop
334 # If kept changes its text, drop the relationship.
337 # If kept / rel already has a relationship, warn and keep the old
338 my $rel = $self->get_relationship( @vector );
340 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
344 # Otherwise, adopt the relationship that would be deleted.
345 $rel = $self->get_relationship( @$edge );
346 $self->_set_relationship( $rel, @vector );
348 $self->delete_reading( $deleted );
352 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
354 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
355 $rgraph->setAttribute( 'edgedefault', 'directed' );
356 $rgraph->setAttribute( 'id', 'relationships', );
357 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
358 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
359 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
360 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
361 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
363 # Add the vertices according to their XML IDs
364 my %rdg_lookup = ( reverse %$node_hash );
365 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
366 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
367 $n_el->setAttribute( 'id', $n );
368 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
371 # Add the relationship edges, with their object information
373 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
374 # Add an edge and fill in its relationship info.
375 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
376 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
377 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
378 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
380 my $rel_obj = $self->get_relationship( @$e );
381 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
382 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
383 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
384 $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
385 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
386 $rel_obj->non_independent ) if $rel_obj->nonind_set;
395 return $tmp_a <=> $tmp_b;
398 sub _add_graphml_data {
399 my( $el, $key, $value ) = @_;
400 return unless defined $value;
401 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
402 $data_el->setAttribute( 'key', $key );
403 $data_el->appendText( $value );
407 __PACKAGE__->meta->make_immutable;