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',
63 =head2 get_relationship
65 Return the relationship object, if any, that exists between two readings.
69 sub get_relationship {
70 my( $self, @vector ) = @_;
72 if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
73 $relationship = $self->graph->get_edge_attribute( @vector, 'object' );
78 sub _set_relationship {
79 my( $self, $relationship, @vector ) = @_;
80 $self->graph->add_edge( @vector );
81 $self->graph->set_edge_attribute( @vector, 'object', $relationship );
84 sub _remove_relationship {
85 my( $self, @vector ) = @_;
86 $self->graph->delete_edge( @vector );
91 Create a new relationship with the given options and return it.
92 Warn and return undef if the relationship cannot be created.
97 my( $self, $options ) = @_;
98 # Check to see if a relationship exists between the two given readings
99 my $source = delete $options->{'orig_a'};
100 my $target = delete $options->{'orig_b'};
101 my $rel = $self->get_relationship( $source, $target );
103 if( $rel->type ne $options->{'type'} ) {
104 throw( "Another relationship of type " . $rel->type
105 . " already exists between $source and $target" );
111 # Check to see if a nonlocal relationship is defined for the two readings
112 $rel = $self->scoped_relationship( $options->{'reading_a'},
113 $options->{'reading_b'} );
114 if( $rel && $rel->type eq $options->{'type'} ) {
117 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'} ) );
119 $rel = Text::Tradition::Collation::Relationship->new( $options );
120 $self->add_scoped_relationship( $rel ) if $rel->nonlocal;
125 =head2 add_scoped_relationship( $rel )
127 Keep track of relationships defined between specific readings that are scoped
128 non-locally. Key on whichever reading occurs first alphabetically.
132 sub add_scoped_relationship {
133 my( $self, $rel ) = @_;
134 my $r = $self->scoped_relationship( $rel->reading_a, $rel->reading_b );
136 warn sprintf( "Scoped relationship of type %s already exists between %s and %s",
137 $r->type, $rel->reading_a, $rel->reading_b );
140 $self->scopedrels->{$rel->reading_a}->{$rel->reading_b} = $rel;
143 =head2 scoped_relationship( $reading_a, $reading_b )
145 Returns the general (document-level or global) relationship that has been defined
146 between the two reading strings. Returns undef if there is no general relationship.
150 sub scoped_relationship {
151 my( $self, $rdga, $rdgb ) = @_;
152 my( $first, $second ) = sort( $rdga, $rdgb );
153 if( exists $self->scopedrels->{$first}->{$second} ) {
154 return $self->scopedrels->{$first}->{$second};
160 =head2 add_relationship( $self, $source, $sourcetext, $target, $targettext, $opts )
162 Adds the relationship specified in $opts (see Text::Tradition::Collation::Relationship
163 for the possible options) between the readings given in $source and $target. Sets
164 up a scoped relationship between $sourcetext and $targettext if the relationship is
167 Returns a status boolean and a list of all reading pairs connected by the call to
172 sub add_relationship {
173 my( $self, $source, $source_rdg, $target, $target_rdg, $options ) = @_;
176 $options->{'scope'} = 'local' unless $options->{'scope'};
178 my( $is_valid, $reason ) =
179 $self->relationship_valid( $source, $target, $options->{'type'} );
180 unless( $is_valid ) {
181 throw( "Invalid relationship: $reason" );
184 # Try to create the relationship object.
185 $options->{'reading_a'} = $source_rdg->text;
186 $options->{'reading_b'} = $target_rdg->text;
187 $options->{'orig_a'} = $source;
188 $options->{'orig_b'} = $target;
189 my $relationship = $self->create( $options ); # Will throw on error
191 # Find all the pairs for which we need to set the relationship.
192 my @vectors = ( [ $source, $target ] );
193 if( $relationship->colocated && $relationship->nonlocal ) {
194 my $c = $self->collation;
195 # Set the same relationship everywhere we can, throughout the graph.
196 my @identical_readings = grep { $_->text eq $relationship->reading_a }
198 foreach my $ir ( @identical_readings ) {
199 next if $ir->id eq $source;
200 # Check to see if there is a target reading with the same text at
203 { $_->rank == $ir->rank && $_->text eq $relationship->reading_b }
207 warn "More than one reading with text " . $target_rdg->text
208 . " at rank " . $ir->rank . "!" if @itarget > 1;
209 push( @vectors, [ $ir->id, $itarget[0]->id ] );
214 # Now set the relationship(s).
216 foreach my $v ( @vectors ) {
217 my $rel = $self->get_relationship( @$v );
219 if( $rel->nonlocal ) {
220 throw( "Found conflicting relationship at @$v" );
222 warn "Not overriding local relationship set at @$v";
226 $self->_set_relationship( $relationship, @$v );
227 push( @pairs_set, $v );
233 =head2 relationship_valid( $source, $target, $type )
235 Checks whether a relationship of type $type may exist between the readings given
236 in $source and $target. Returns a tuple of ( status, message ) where status is
237 a yes/no boolean and, if the answer is no, message gives the reason why.
241 sub relationship_valid {
242 my( $self, $source, $target, $rel ) = @_;
243 my $c = $self->collation;
244 if ( $rel eq 'transposition' || $rel eq 'repetition' ) {
245 # Check that the two readings do (for a repetition) or do not (for
246 # a transposition) appear in the same witness.
248 map { $seen_wits{$_} = 1 } $c->reading_witnesses( $source );
249 foreach my $w ( $c->reading_witnesses( $target ) ) {
250 if( $seen_wits{$w} ) {
251 return ( 0, "Readings both occur in witness $w" )
252 if $rel eq 'transposition';
253 return ( 1, "ok" ) if $rel eq 'repetition';
255 return $rel eq 'transposition' ? ( 1, "ok" )
256 : ( 0, "Readings occur only in distinct witnesses" );
259 # Check that linking the source and target in a relationship won't lead
260 # to a path loop for any witness. If they have the same rank then fine.
262 if $c->reading( $source )->rank == $c->reading( $target )->rank;
264 # Otherwise, first make a lookup table of all the
265 # readings related to either the source or the target.
266 my @proposed_related = ( $source, $target );
267 push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
268 push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
270 map { $pr_ids{ $_ } = 1 } @proposed_related;
272 # The cumulative predecessors and successors of the proposed-related readings
273 # should not overlap.
276 foreach my $pr ( keys %pr_ids ) {
277 map { $all_pred{$_} = 1 } $c->sequence->all_predecessors( $pr );
278 map { $all_succ{$_} = 1 } $c->sequence->all_successors( $pr );
280 foreach my $k ( keys %all_pred ) {
281 return( 0, "Relationship would create witness loop" )
282 if exists $all_succ{$k};
284 foreach my $k ( keys %pr_ids ) {
285 return( 0, "Relationship would create witness loop" )
286 if exists $all_pred{$k} || exists $all_succ{$k};
292 =head2 related_readings( $reading, $colocated_only )
294 Returns a list of readings that are connected via relationship links to $reading.
295 If $colocated_only is true, restricts the list to those readings that are in the
296 same logical location (and therefore have the same rank in the collation graph.)
300 sub related_readings {
301 my( $self, $reading, $colocated ) = @_;
303 if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
304 $reading = $reading->id;
309 my %found = ( $reading => 1 );
310 my $check = [ $reading ];
314 foreach my $r ( @$check ) {
315 foreach my $nr ( $self->graph->neighbors( $r ) ) {
316 if( $self->get_relationship( $r, $nr )->colocated ) {
317 push( @$more, $nr ) unless exists $found{$nr};
324 @answer = keys %found;
326 @answer = $self->graph->all_reachable( $reading );
328 if( $return_object ) {
329 my $c = $self->collation;
330 return map { $c->reading( $_ ) } @answer;
336 =head2 merge_readings( $kept, $deleted );
338 Makes a best-effort merge of the relationship links between the given readings, and
339 stops tracking the to-be-deleted reading.
344 my( $self, $kept, $deleted, $combined ) = @_;
345 foreach my $edge ( $self->graph->edges_at( $deleted ) ) {
346 # Get the pair of kept / rel
347 my @vector = ( $kept );
348 push( @vector, $edge->[0] eq $deleted ? $edge->[1] : $edge->[0] );
349 next if $vector[0] eq $vector[1]; # Don't add a self loop
351 # If kept changes its text, drop the relationship.
354 # If kept / rel already has a relationship, warn and keep the old
355 my $rel = $self->get_relationship( @vector );
357 warn sprintf( "Readings %s and %s have existing relationship; dropping link with %s", @vector, $deleted );
361 # Otherwise, adopt the relationship that would be deleted.
362 $rel = $self->get_relationship( @$edge );
363 $self->_set_relationship( $rel, @vector );
365 $self->delete_reading( $deleted );
369 my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
371 my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
372 $rgraph->setAttribute( 'edgedefault', 'directed' );
373 $rgraph->setAttribute( 'id', 'relationships', );
374 $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
375 $rgraph->setAttribute( 'parse.edges', scalar($self->graph->edges) );
376 $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
377 $rgraph->setAttribute( 'parse.nodes', scalar($self->graph->vertices) );
378 $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
380 # Add the vertices according to their XML IDs
381 my %rdg_lookup = ( reverse %$node_hash );
382 foreach my $n ( sort _by_xmlid keys( %rdg_lookup ) ) {
383 my $n_el = $rgraph->addNewChild( $graphml_ns, 'node' );
384 $n_el->setAttribute( 'id', $n );
385 _add_graphml_data( $n_el, $nodeid_key, $rdg_lookup{$n} );
388 # Add the relationship edges, with their object information
390 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->graph->edges ) {
391 # Add an edge and fill in its relationship info.
392 my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
393 $edge_el->setAttribute( 'source', $node_hash->{$e->[0]} );
394 $edge_el->setAttribute( 'target', $node_hash->{$e->[1]} );
395 $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
397 my $rel_obj = $self->get_relationship( @$e );
398 _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
399 _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
400 _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'},
401 $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
402 _add_graphml_data( $edge_el, $edge_keys->{'non_independent'},
403 $rel_obj->non_independent ) if $rel_obj->nonind_set;
412 return $tmp_a <=> $tmp_b;
415 sub _add_graphml_data {
416 my( $el, $key, $value ) = @_;
417 return unless defined $value;
418 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
419 $data_el->setAttribute( 'key', $key );
420 $data_el->appendText( $value );
424 Text::Tradition::Error->throw(
425 'ident' => 'Relationship error',
431 __PACKAGE__->meta->make_immutable;