1 package Text::Tradition::Collation;
4 use Encode qw( decode_utf8 );
8 use IPC::Run qw( run binary );
10 use Text::Tradition::Collation::Data;
11 use Text::Tradition::Collation::Reading;
12 use Text::Tradition::Collation::RelationshipStore;
13 use Text::Tradition::Error;
14 use XML::Easy::Syntax qw( $xml10_namestartchar_rx $xml10_namechar_rx );
16 use XML::LibXML::XPathContext;
20 isa => 'Text::Tradition::Collation::Data',
58 isa => 'Text::Tradition',
59 writer => '_set_tradition',
65 Text::Tradition::Collation - a software model for a text collation
70 my $t = Text::Tradition->new(
71 'name' => 'this is a text',
73 'file' => '/path/to/tei_parallel_seg_file.xml' );
75 my $c = $t->collation;
76 my @readings = $c->readings;
77 my @paths = $c->paths;
78 my @relationships = $c->relationships;
80 my $svg_variant_graph = $t->collation->as_svg();
84 Text::Tradition is a library for representation and analysis of collated
85 texts, particularly medieval ones. The Collation is the central feature of
86 a Tradition, where the text, its sequence of readings, and its relationships
87 between readings are actually kept.
93 The constructor. Takes a hash or hashref of the following arguments:
97 =item * tradition - The Text::Tradition object to which the collation
100 =item * linear - Whether the collation should be linear; that is, whether
101 transposed readings should be treated as two linked readings rather than one,
102 and therefore whether the collation graph is acyclic. Defaults to true.
104 =item * baselabel - The default label for the path taken by a base text
105 (if any). Defaults to 'base text'.
107 =item * wit_list_separator - The string to join a list of witnesses for
108 purposes of making labels in display graphs. Defaults to ', '.
110 =item * ac_label - The extra label to tack onto a witness sigil when
111 representing another layer of path for the given witness - that is, when
112 a text has more than one possible reading due to scribal corrections or
113 the like. Defaults to ' (a.c.)'.
115 =item * wordsep - The string used to separate words in the original text.
126 =head2 wit_list_separator
134 Simple accessors for collation attributes.
138 The meta-reading at the start of every witness path.
142 The meta-reading at the end of every witness path.
146 Returns all Reading objects in the graph.
148 =head2 reading( $id )
150 Returns the Reading object corresponding to the given ID.
152 =head2 add_reading( $reading_args )
154 Adds a new reading object to the collation.
155 See L<Text::Tradition::Collation::Reading> for the available arguments.
157 =head2 del_reading( $object_or_id )
159 Removes the given reading from the collation, implicitly removing its
160 paths and relationships.
162 =head2 has_reading( $id )
164 Predicate to see whether a given reading ID is in the graph.
166 =head2 reading_witnesses( $object_or_id )
168 Returns a list of sigils whose witnesses contain the reading.
172 Returns all reading paths within the document - that is, all edges in the
173 collation graph. Each path is an arrayref of [ $source, $target ] reading IDs.
175 =head2 add_path( $source, $target, $sigil )
177 Links the given readings in the collation in sequence, under the given witness
178 sigil. The readings may be specified by object or ID.
180 =head2 del_path( $source, $target, $sigil )
182 Links the given readings in the collation in sequence, under the given witness
183 sigil. The readings may be specified by object or ID.
185 =head2 has_path( $source, $target );
187 Returns true if the two readings are linked in sequence in any witness.
188 The readings may be specified by object or ID.
192 Returns all Relationship objects in the collation.
194 =head2 add_relationship( $reading, $other_reading, $options )
196 Adds a new relationship of the type given in $options between the two readings,
197 which may be specified by object or ID. Returns a value of ( $status, @vectors)
198 where $status is true on success, and @vectors is a list of relationship edges
199 that were ultimately added.
200 See L<Text::Tradition::Collation::Relationship> for the available options.
205 my ( $class, @args ) = @_;
206 my %args = @args == 1 ? %{ $args[0] } : @args;
207 # TODO determine these from the Moose::Meta object
208 my @delegate_attrs = qw(sequence relations readings wit_list_separator baselabel
209 linear wordsep start end cached_table _graphcalc_done);
211 for my $attr (@delegate_attrs) {
212 $data_args{$attr} = delete $args{$attr} if exists $args{$attr};
214 $args{_data} = Text::Tradition::Collation::Data->new(%data_args);
220 $self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
221 $self->_set_start( $self->add_reading(
222 { 'collation' => $self, 'is_start' => 1, 'init' => 1 } ) );
223 $self->_set_end( $self->add_reading(
224 { 'collation' => $self, 'is_end' => 1, 'init' => 1 } ) );
227 sub register_relationship_type {
229 my %args = @_ == 1 ? %{$_[0]} : @_;
230 if( $self->relations->has_type( $args{name} ) ) {
231 throw( 'Relationship type ' . $args{name} . ' already registered' );
233 $self->relations->add_type( %args );
236 sub get_relationship_type {
237 my( $self, $name ) = @_;
238 return $self->relations->has_type( $name )
239 ? $self->relations->type( $name ) : undef;
242 ### Reading construct/destruct functions
245 my( $self, $reading ) = @_;
246 unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
247 my %args = %$reading;
248 if( $args{'init'} ) {
249 # If we are initializing an empty collation, don't assume that we
250 # have set a tradition.
251 delete $args{'init'};
252 } elsif( $self->tradition->can('language') && $self->tradition->has_language
253 && !exists $args{'language'} ) {
254 $args{'language'} = $self->tradition->language;
256 $reading = Text::Tradition::Collation::Reading->new(
257 'collation' => $self,
260 # First check to see if a reading with this ID exists.
261 if( $self->reading( $reading->id ) ) {
262 throw( "Collation already has a reading with id " . $reading->id );
264 $self->_graphcalc_done(0);
265 $self->_add_reading( $reading->id => $reading );
266 # Once the reading has been added, put it in both graphs.
267 $self->sequence->add_vertex( $reading->id );
268 $self->relations->add_reading( $reading->id );
272 around del_reading => sub {
277 if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
280 # Remove the reading from the graphs.
281 $self->_graphcalc_done(0);
282 $self->_clear_cache; # Explicitly clear caches to GC the reading
283 $self->sequence->delete_vertex( $arg );
284 $self->relations->delete_reading( $arg );
287 $self->$orig( $arg );
290 =head2 merge_readings( $main, $second, $concatenate, $with_str )
292 Merges the $second reading into the $main one. If $concatenate is true, then
293 the merged node will carry the text of both readings, concatenated with either
294 $with_str (if specified) or a sensible default (the empty string if the
295 appropriate 'join_*' flag is set on either reading, or else $self->wordsep.)
297 The first two arguments may be either readings or reading IDs.
304 my $cxfile = 't/data/Collatex-16.xml';
305 my $t = Text::Tradition->new(
307 'input' => 'CollateX',
310 my $c = $t->collation;
312 my $rno = scalar $c->readings;
313 # Split n21 ('unto') for testing purposes
314 my $new_r = $c->add_reading( { 'id' => 'n21p0', 'text' => 'un', 'join_next' => 1 } );
315 my $old_r = $c->reading( 'n21' );
316 $old_r->alter_text( 'to' );
317 $c->del_path( 'n20', 'n21', 'A' );
318 $c->add_path( 'n20', 'n21p0', 'A' );
319 $c->add_path( 'n21p0', 'n21', 'A' );
320 $c->add_relationship( 'n21', 'n22', { type => 'collated', scope => 'local' } );
322 ok( $c->reading( 'n21p0' ), "New reading exists" );
323 is( scalar $c->readings, $rno, "Reading add offset by flatten_ranks" );
325 # Combine n3 and n4 ( with his )
326 $c->merge_readings( 'n3', 'n4', 1 );
327 ok( !$c->reading('n4'), "Reading n4 is gone" );
328 is( $c->reading('n3')->text, 'with his', "Reading n3 has both words" );
330 # Collapse n9 and n10 ( rood / root )
331 $c->merge_readings( 'n9', 'n10' );
332 ok( !$c->reading('n10'), "Reading n10 is gone" );
333 is( $c->reading('n9')->text, 'rood', "Reading n9 has an unchanged word" );
335 # Try to combine n21 and n21p0. This should break.
336 my $remaining = $c->reading('n21');
337 $remaining ||= $c->reading('n22'); # one of these should still exist
339 $c->merge_readings( 'n21p0', $remaining, 1 );
340 ok( 0, "Bad reading merge changed the graph" );
341 } catch( Text::Tradition::Error $e ) {
342 like( $e->message, qr/neither concatenated nor collated/, "Expected exception from bad concatenation" );
344 ok( 0, "Unexpected error on bad reading merge: $@" );
348 $c->calculate_ranks();
349 ok( 1, "Graph is still evidently whole" );
350 } catch( Text::Tradition::Error $e ) {
351 ok( 0, "Caught a rank exception: " . $e->message );
362 my( $kept_obj, $del_obj, $combine, $combine_char ) = $self->_objectify_args( @_ );
363 my $mergemeta = $kept_obj->is_meta;
364 throw( "Cannot merge meta and non-meta reading" )
365 unless ( $mergemeta && $del_obj->is_meta )
366 || ( !$mergemeta && !$del_obj->is_meta );
368 throw( "Cannot merge with start or end node" )
369 if( $kept_obj eq $self->start || $kept_obj eq $self->end
370 || $del_obj eq $self->start || $del_obj eq $self->end );
371 throw( "Cannot combine text of meta readings" ) if $combine;
373 # We can only merge readings in a linear graph if:
374 # - they are contiguous with only one edge between them, OR
375 # - they are at equivalent ranks in the graph.
376 if( $self->linear ) {
377 my @delpred = $del_obj->predecessors;
378 my @keptsuc = $kept_obj->successors;
379 unless ( @delpred == 1 && $delpred[0] eq $kept_obj
380 && @keptsuc == 1 && $keptsuc[0] eq $del_obj ) {
381 my( $is_ok, $msg ) = $self->relations->relationship_valid(
382 $kept_obj, $del_obj, 'collated' );
384 throw( "Readings $kept_obj and $del_obj can be neither concatenated nor collated" );
389 # We only need the IDs for adding paths to the graph, not the reading
390 # objects themselves.
391 my $kept = $kept_obj->id;
392 my $deleted = $del_obj->id;
393 $self->_graphcalc_done(0);
395 # The kept reading should inherit the paths and the relationships
396 # of the deleted reading.
397 foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
398 my @vector = ( $kept );
399 push( @vector, $path->[1] ) if $path->[0] eq $deleted;
400 unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
401 next if $vector[0] eq $vector[1]; # Don't add a self loop
402 my %wits = %{$self->sequence->get_edge_attributes( @$path )};
403 $self->sequence->add_edge( @vector );
404 my $fwits = $self->sequence->get_edge_attributes( @vector );
405 @wits{keys %$fwits} = values %$fwits;
406 $self->sequence->set_edge_attributes( @vector, \%wits );
408 $self->relations->merge_readings( $kept, $deleted, $combine );
410 # Do the deletion deed.
412 # Combine the text of the readings
413 my $joinstr = $combine_char;
414 unless( defined $joinstr ) {
415 $joinstr = '' if $kept_obj->join_next || $del_obj->join_prior;
416 $joinstr = $self->wordsep unless defined $joinstr;
418 $kept_obj->_combine( $del_obj, $joinstr );
420 $self->del_reading( $deleted );
423 =head2 merge_related( @relationship_types )
425 Merge all readings linked with the relationship types given. If any of the selected type(s) is not a colocation, the graph will no longer be linear. The majority/plurality reading in each case will be the one kept.
427 WARNING: This operation cannot be undone.
439 $t = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/legendfrag.xml' );
440 } [qr/Cannot set relationship on a meta reading/],
441 "Got expected relationship drop warning on parse";
443 my $c = $t->collation;
446 map { $rdg_ids{$_} = 1 } $c->readings;
447 $c->merge_related( 'orthographic' );
448 is( scalar( $c->readings ), keys( %rdg_ids ) - 8,
449 "Successfully collapsed orthographic variation" );
450 map { $rdg_ids{$_} = undef } qw/ r13.3 r11.4 r8.5 r8.2 r7.7 r7.5 r7.4 r7.1 /;
451 foreach my $rid ( keys %rdg_ids ) {
452 my $exp = $rdg_ids{$rid};
453 is( !$c->reading( $rid ), !$exp, "Reading $rid correctly " .
454 ( $exp ? "retained" : "removed" ) );
456 ok( $c->linear, "Graph is still linear" );
458 $c->calculate_ranks; # This should succeed
459 ok( 1, "Can still calculate ranks on the new graph" );
461 ok( 0, "Rank calculation on merged graph failed: $@" );
464 # Now add some transpositions
465 $c->add_relationship( 'r8.4', 'r10.4', { type => 'transposition' } );
466 $c->merge_related( 'transposition' );
467 is( scalar( $c->readings ), keys( %rdg_ids ) - 9,
468 "Transposed relationship is merged away" );
469 ok( !$c->reading('r8.4'), "Correct transposed reading removed" );
470 ok( !$c->linear, "Graph is no longer linear" );
472 $c->calculate_ranks; # This should fail
473 ok( 0, "Rank calculation happened on nonlinear graph?!" );
474 } catch ( Text::Tradition::Error $e ) {
475 is( $e->message, 'Cannot calculate ranks on a non-linear graph',
476 "Rank calculation on merged graph threw an error" );
483 # TODO: there should be a way to display merged without affecting the underlying data!
488 map { $reltypehash{$_} = 1 } @_;
490 # Set up the filter for finding related readings
492 exists $reltypehash{$_[0]->type};
495 # Go through all readings looking for related ones
496 foreach my $r ( $self->readings ) {
497 next unless $self->reading( "$r" ); # might have been deleted meanwhile
498 my @related = $self->related_readings( $r, $filter );
500 push( @related, $r );
502 scalar $b->witnesses <=> scalar $a->witnesses
504 my $keep = shift @related;
505 foreach my $delr ( @related ) {
507 unless( $self->get_relationship( $keep, $delr )->colocated );
508 $self->merge_readings( $keep, $delr );
514 =head2 compress_readings
516 Where possible in the graph, compresses plain sequences of readings into a
517 single reading. The sequences must consist of readings with no
518 relationships to other readings, with only a single witness path between
519 them and no other witness paths from either that would skip the other. The
520 readings must also not be marked as nonsense or bad grammar.
522 WARNING: This operation cannot be undone.
526 sub compress_readings {
528 # Anywhere in the graph that there is a reading that joins only to a single
529 # successor, and neither of these have any relationships, just join the two
531 foreach my $rdg ( sort { $a->rank <=> $b->rank } $self->readings ) {
532 # Now look for readings that can be joined to their successors.
533 next unless $rdg->is_combinable;
535 while( $self->sequence->successors( $rdg ) == 1 ) {
536 my( $next ) = $self->reading( $self->sequence->successors( $rdg ) );
537 throw( "Infinite loop" ) if $seen{$next->id};
538 $seen{$next->id} = 1;
539 last if $self->sequence->predecessors( $next ) > 1;
540 last unless $next->is_combinable;
541 say "Joining readings $rdg and $next";
542 $self->merge_readings( $rdg, $next, 1 );
545 # Make sure we haven't screwed anything up
546 foreach my $wit ( $self->tradition->witnesses ) {
547 my $pathtext = $self->path_text( $wit->sigil );
548 my $origtext = join( ' ', @{$wit->text} );
549 throw( "Text differs for witness " . $wit->sigil )
550 unless $pathtext eq $origtext;
551 if( $wit->is_layered ) {
552 $pathtext = $self->path_text( $wit->sigil.$self->ac_label );
553 $origtext = join( ' ', @{$wit->layertext} );
554 throw( "Ante-corr text differs for witness " . $wit->sigil )
555 unless $pathtext eq $origtext;
559 $self->relations->rebuild_equivalence();
560 $self->calculate_ranks();
563 # Helper function for manipulating the graph.
564 sub _stringify_args {
565 my( $self, $first, $second, @args ) = @_;
567 if ref( $first ) eq 'Text::Tradition::Collation::Reading';
568 $second = $second->id
569 if ref( $second ) eq 'Text::Tradition::Collation::Reading';
570 return( $first, $second, @args );
573 # Helper function for manipulating the graph.
574 sub _objectify_args {
575 my( $self, $first, $second, $arg ) = @_;
576 $first = $self->reading( $first )
577 unless ref( $first ) eq 'Text::Tradition::Collation::Reading';
578 $second = $self->reading( $second )
579 unless ref( $second ) eq 'Text::Tradition::Collation::Reading';
580 return( $first, $second, $arg );
583 =head2 duplicate_reading( $reading, @witlist )
585 Split the given reading into two, so that the new reading is in the path for
586 the witnesses given in @witlist. If the result is that certain non-colocated
587 relationships (e.g. transpositions) are no longer valid, these will be removed.
588 Returns the newly-created reading.
592 use Test::More::UTF8;
596 my $st = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/collatecorr.xml' );
597 is( ref( $st ), 'Text::Tradition', "Got a tradition from test file" );
598 ok( $st->has_witness('Ba96'), "Tradition has the affected witness" );
600 my $sc = $st->collation;
602 ok( $sc->reading('n131'), "Tradition has the affected reading" );
603 is( scalar( $sc->readings ), $numr, "There are $numr readings in the graph" );
604 is( $sc->end->rank, 14, "There are fourteen ranks in the graph" );
606 # Detach the erroneously collated reading
607 my( $newr, @del_rdgs ) = $sc->duplicate_reading( 'n131', 'Ba96' );
608 ok( $newr, "New reading was created" );
609 ok( $sc->reading('n131_0'), "Detached the bad collation with a new reading" );
610 is( scalar( $sc->readings ), $numr + 1, "A reading was added to the graph" );
611 is( $sc->end->rank, 10, "There are now only ten ranks in the graph" );
612 my $csucc = $sc->common_successor( 'n131', 'n131_0' );
613 is( $csucc->id, 'n136', "Found correct common successor to duped reading" );
615 # Check that the bad transposition is gone
616 is( scalar @del_rdgs, 1, "Deleted reading was returned by API call" );
617 is( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
619 # The collation should not be fixed
620 my @pairs = $sc->identical_readings();
621 is( scalar @pairs, 0, "Not re-collated yet" );
623 ok( $sc->merge_readings( 'n124', 'n131_0' ), "Collated the readings correctly" );
624 @pairs = $sc->identical_readings( start => 'n124', end => $csucc->id );
625 is( scalar @pairs, 3, "Found three more identical readings" );
626 is( $sc->end->rank, 11, "The ranks shifted appropriately" );
627 $sc->flatten_ranks();
628 is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
630 # Check that we can't "duplicate" a reading with no wits or with all wits
632 my( $badr, @del_rdgs ) = $sc->duplicate_reading( 'n124' );
633 ok( 0, "Reading duplication without witnesses throws an error" );
634 } catch( Text::Tradition::Error $e ) {
635 like( $e->message, qr/Must specify one or more witnesses/,
636 "Reading duplication without witnesses throws the expected error" );
638 ok( 0, "Reading duplication without witnesses threw the wrong error" );
642 my( $badr, @del_rdgs ) = $sc->duplicate_reading( 'n124', 'Ba96', 'Mü11475' );
643 ok( 0, "Reading duplication with all witnesses throws an error" );
644 } catch( Text::Tradition::Error $e ) {
645 like( $e->message, qr/Cannot join all witnesses/,
646 "Reading duplication with all witnesses throws the expected error" );
648 ok( 0, "Reading duplication with all witnesses threw the wrong error" );
652 $sc->calculate_ranks();
653 ok( 1, "Graph is still evidently whole" );
654 } catch( Text::Tradition::Error $e ) {
655 ok( 0, "Caught a rank exception: " . $e->message );
662 sub duplicate_reading {
663 my( $self, $r, @wits ) = @_;
664 # Check that we are not doing anything unwise.
665 throw( "Must specify one or more witnesses for the duplicated reading" )
667 unless( ref( $r ) eq 'Text::Tradition::Collation::Reading' ) {
668 $r = $self->reading( $r );
670 throw( "Cannot duplicate a meta-reading" )
672 throw( "Cannot join all witnesses to the new reading" )
673 if scalar( @wits ) == scalar( $r->witnesses );
675 # Get all the reading attributes and duplicate them.
676 my $rmeta = Text::Tradition::Collation::Reading->meta;
678 foreach my $attr( $rmeta->get_all_attributes ) {
679 next if $attr->name =~ /^_/;
680 my $acc = $attr->get_read_method;
681 if( !$acc && $attr->has_applied_traits ) {
682 my $tr = $attr->applied_traits;
683 if( $tr->[0] =~ /::(Array|Hash)$/ ) {
685 my %methods = reverse %{$attr->handles};
686 $acc = $methods{elements};
687 $args{$attr->name} = $which eq 'Array'
688 ? [ $r->$acc ] : { $r->$acc };
691 $args{$attr->name} = $r->$acc if $acc;
694 # By definition the new reading will no longer be common.
695 $args{is_common} = 0;
696 # The new reading also needs its own ID.
697 $args{id} = $self->_generate_dup_id( $r->id );
699 # Try to make the new reading.
700 my $newr = $self->add_reading( \%args );
701 # The old reading is also no longer common.
704 # For each of the witnesses, dissociate from the old reading and
705 # associate with the new.
706 foreach my $wit ( @wits ) {
707 my $prior = $self->prior_reading( $r, $wit );
708 my $next = $self->next_reading( $r, $wit );
709 $self->del_path( $prior, $r, $wit );
710 $self->add_path( $prior, $newr, $wit );
711 $self->del_path( $r, $next, $wit );
712 $self->add_path( $newr, $next, $wit );
715 # If the graph is ranked, we need to look for relationships that are now
716 # invalid (i.e. 'non-colocation' types that might now be colocated) and
717 # remove them. If not, we can skip it.
720 my @deleted_relations;
721 if( $self->end->has_rank ) {
722 # Find the point where we can stop checking
723 $succ = $self->common_successor( $r, $newr );
725 # Hash the existing ranks
726 foreach my $rdg ( $self->readings ) {
727 $rrk{$rdg->id} = $rdg->rank;
729 # Calculate the new ranks
730 $self->calculate_ranks();
732 # Check for invalid non-colocated relationships among changed-rank readings
733 # from where the ranks start changing up to $succ
734 my $lastrank = $succ->rank;
735 foreach my $rdg ( $self->readings ) {
736 next if $rdg->rank > $lastrank;
737 next if $rdg->rank == $rrk{$rdg->id};
738 my @noncolo = $rdg->related_readings( sub { !$_[0]->colocated } );
739 next unless @noncolo;
740 foreach my $nc ( @noncolo ) {
741 unless( $self->relations->verify_or_delete( $rdg, $nc ) ) {
742 push( @deleted_relations, [ $rdg->id, $nc->id ] );
747 return ( $newr, @deleted_relations );
750 sub _generate_dup_id {
751 my( $self, $rid ) = @_;
756 if( $self->has_reading( $newid ) ) {
769 # We only need the IDs for adding paths to the graph, not the reading
770 # objects themselves.
771 my( $source, $target, $wit ) = $self->_stringify_args( @_ );
773 $self->_graphcalc_done(0);
774 # Connect the readings
775 unless( $self->sequence->has_edge( $source, $target ) ) {
776 $self->sequence->add_edge( $source, $target );
777 $self->relations->add_equivalence_edge( $source, $target );
779 # Note the witness in question
780 $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
786 if( ref( $_[0] ) eq 'ARRAY' ) {
793 # We only need the IDs for removing paths from the graph, not the reading
794 # objects themselves.
795 my( $source, $target, $wit ) = $self->_stringify_args( @args );
797 $self->_graphcalc_done(0);
798 if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
799 $self->sequence->delete_edge_attribute( $source, $target, $wit );
801 unless( $self->sequence->has_edge_attributes( $source, $target ) ) {
802 $self->sequence->delete_edge( $source, $target );
803 $self->relations->delete_equivalence_edge( $source, $target );
808 # Extra graph-alike utility
811 my( $source, $target, $wit ) = $self->_stringify_args( @_ );
812 return undef unless $self->sequence->has_edge( $source, $target );
813 return $self->sequence->has_edge_attribute( $source, $target, $wit );
816 =head2 clear_witness( @sigil_list )
818 Clear the given witnesses out of the collation entirely, removing references
819 to them in paths, and removing readings that belong only to them. Should only
820 be called via $tradition->del_witness.
825 my( $self, @sigils ) = @_;
827 $self->_graphcalc_done(0);
828 # Clear the witness(es) out of the paths
829 foreach my $e ( $self->paths ) {
830 foreach my $sig ( @sigils ) {
831 $self->del_path( $e, $sig );
835 # Clear out the newly unused readings
836 foreach my $r ( $self->readings ) {
837 unless( $self->reading_witnesses( $r ) ) {
838 $self->del_reading( $r );
843 sub add_relationship {
845 my( $source, $target, $opts ) = $self->_stringify_args( @_ );
846 my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
847 foreach my $v ( @vectors ) {
848 next unless $self->get_relationship( $v )->colocated;
849 if( $self->reading( $v->[0] )->has_rank && $self->reading( $v->[1] )->has_rank
850 && $self->reading( $v->[0] )->rank ne $self->reading( $v->[1] )->rank ) {
851 $self->_graphcalc_done(0);
859 around qw/ get_relationship del_relationship / => sub {
863 if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
866 my @stringargs = $self->_stringify_args( @args );
867 $self->$orig( @stringargs );
870 =head2 reading_witnesses( $reading )
872 Return a list of sigils corresponding to the witnesses in which the reading appears.
876 sub reading_witnesses {
877 my( $self, $reading ) = @_;
878 # We need only check either the incoming or the outgoing edges; I have
879 # arbitrarily chosen "incoming". Thus, special-case the start node.
880 if( $reading eq $self->start ) {
881 return map { $_->sigil } grep { $_->is_collated } $self->tradition->witnesses;
884 foreach my $e ( $self->sequence->edges_to( $reading ) ) {
885 my $wits = $self->sequence->get_edge_attributes( @$e );
886 @all_witnesses{ keys %$wits } = 1;
888 my $acstr = $self->ac_label;
889 foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
890 delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
892 return keys %all_witnesses;
895 =head1 OUTPUT METHODS
897 =head2 as_svg( \%options )
899 Returns an SVG string that represents the graph, via as_dot and graphviz.
900 See as_dot for a list of options. Must have GraphViz (dot) installed to run.
905 my( $self, $opts ) = @_;
906 throw( "Need GraphViz installed to output SVG" )
907 unless File::Which::which( 'dot' );
908 my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
909 $self->calculate_ranks()
910 unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
911 my @cmd = qw/dot -Tsvg/;
913 my $dotfile = File::Temp->new();
915 # $dotfile->unlink_on_destroy(0);
916 binmode $dotfile, ':utf8';
917 print $dotfile $self->as_dot( $opts );
918 push( @cmd, $dotfile->filename );
919 run( \@cmd, ">", binary(), \$svg );
920 $svg = decode_utf8( $svg );
925 =head2 as_dot( \%options )
927 Returns a string that is the collation graph expressed in dot
928 (i.e. GraphViz) format. Options include:
943 my( $self, $opts ) = @_;
944 my $startrank = $opts->{'from'} if $opts;
945 my $endrank = $opts->{'to'} if $opts;
946 my $color_common = $opts->{'color_common'} if $opts;
947 my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
948 && $self->end->rank > 100;
949 $STRAIGHTENHACK = 1 if $opts->{'straight'}; # even for subgraphs or small graphs
951 # Check the arguments
953 return if $endrank && $startrank > $endrank;
954 return if $startrank > $self->end->rank;
956 if( defined $endrank ) {
957 return if $endrank < 0;
958 $endrank = undef if $endrank == $self->end->rank;
961 my $graph_name = $self->tradition->name;
962 $graph_name =~ s/[^\w\s]//g;
963 $graph_name = join( '_', split( /\s+/, $graph_name ) );
971 'fillcolor' => 'white',
976 'arrowhead' => 'open',
977 'color' => '#000000',
978 'fontcolor' => '#000000',
981 my $dot = sprintf( "digraph %s {\n", $graph_name );
982 $dot .= "\tgraph " . _dot_attr_string( \%graph_attrs ) . ";\n";
983 $dot .= "\tnode " . _dot_attr_string( \%node_attrs ) . ";\n";
985 # Output substitute start/end readings if necessary
987 $dot .= "\t\"__SUBSTART__\" [ label=\"...\",id=\"__START__\" ];\n";
990 $dot .= "\t\"__SUBEND__\" [ label=\"...\",id=\"__END__\" ];\n";
992 if( $STRAIGHTENHACK ) {
994 my $startlabel = $startrank ? '__SUBSTART__' : '__START__';
995 $dot .= "\tsubgraph { rank=same \"$startlabel\" \"#SILENT#\" }\n";
996 $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];"
998 my %used; # Keep track of the readings that actually appear in the graph
999 # Sort the readings by rank if we have ranks; this speeds layout.
1000 my @all_readings = $self->end->has_rank
1001 ? sort { $a->rank <=> $b->rank } $self->readings
1003 # TODO Refrain from outputting lacuna nodes - just grey out the edges.
1004 foreach my $reading ( @all_readings ) {
1005 # Only output readings within our rank range.
1006 next if $startrank && $reading->rank < $startrank;
1007 next if $endrank && $reading->rank > $endrank;
1008 $used{$reading->id} = 1;
1009 # Need not output nodes without separate labels
1010 next if $reading->id eq $reading->text;
1012 my $label = $reading->text;
1013 $label .= '-' if $reading->join_next;
1014 $label = "-$label" if $reading->join_prior;
1015 $label =~ s/\"/\\\"/g;
1016 $rattrs->{'label'} = $label;
1017 $rattrs->{'id'} = $reading->id;
1018 $rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
1019 $dot .= sprintf( "\t\"%s\" %s;\n", $reading->id, _dot_attr_string( $rattrs ) );
1022 # Add the real edges. Need to weight one edge per rank jump, in a
1024 # my $weighted = $self->_add_edge_weights;
1025 my @edges = $self->paths;
1026 my( %substart, %subend );
1027 foreach my $edge ( @edges ) {
1028 # Do we need to output this edge?
1029 if( $used{$edge->[0]} && $used{$edge->[1]} ) {
1030 my $label = $self->_path_display_label( $opts,
1031 $self->path_witnesses( $edge ) );
1032 my $variables = { %edge_attrs, 'label' => $label };
1034 # Account for the rank gap if necessary
1035 my $rank0 = $self->reading( $edge->[0] )->rank
1036 if $self->reading( $edge->[0] )->has_rank;
1037 my $rank1 = $self->reading( $edge->[1] )->rank
1038 if $self->reading( $edge->[1] )->has_rank;
1039 if( defined $rank0 && defined $rank1 && $rank1 - $rank0 > 1 ) {
1040 $variables->{'minlen'} = $rank1 - $rank0;
1043 # Add the calculated edge weights
1044 # if( exists $weighted->{$edge->[0]}
1045 # && $weighted->{$edge->[0]} eq $edge->[1] ) {
1046 # # $variables->{'color'} = 'red';
1047 # $variables->{'weight'} = 3.0;
1050 # EXPERIMENTAL: make edge width reflect no. of witnesses
1051 my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
1052 $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
1054 my $varopts = _dot_attr_string( $variables );
1055 $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
1056 $edge->[0], $edge->[1], $varopts );
1057 } elsif( $used{$edge->[0]} ) {
1058 $subend{$edge->[0]} = $edge->[1];
1059 } elsif( $used{$edge->[1]} ) {
1060 $substart{$edge->[1]} = $edge->[0];
1064 # If we are asked to, add relationship links
1065 if( exists $opts->{show_relations} ) {
1066 my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
1067 if( $filter eq 'transposition' ) {
1068 $filter =~ qr/^transposition$/;
1071 my @types = sort( map { $_->name } $self->relations->types );
1072 if( exists $opts->{graphcolors} ) {
1073 foreach my $tdx ( 0 .. $#types ) {
1074 $typecolors{$types[$tdx]} = $opts->{graphcolors}->[$tdx];
1077 map { $typecolors{$_} = '#FFA14F' } @types;
1079 foreach my $redge ( $self->relationships ) {
1080 if( $used{$redge->[0]} && $used{$redge->[1]} ) {
1081 my $rel = $self->get_relationship( $redge );
1082 next unless $filter eq 'all' || $rel->type =~ /$filter/;
1084 arrowhead => 'none',
1085 color => $typecolors{$rel->type},
1086 constraint => 'false',
1089 unless( exists $opts->{graphcolors} ) {
1090 $variables->{label} = uc( substr( $rel->type, 0, 4 ) ),
1092 $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
1093 $redge->[0], $redge->[1], _dot_attr_string( $variables ) );
1098 # Add substitute start and end edges if necessary
1099 foreach my $node ( keys %substart ) {
1100 my $witstr = $self->_path_display_label( $opts,
1101 $self->path_witnesses( $substart{$node}, $node ) );
1102 my $variables = { %edge_attrs, 'label' => $witstr };
1103 my $nrdg = $self->reading( $node );
1104 if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
1105 # Substart is actually one lower than $startrank
1106 $variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
1108 my $varopts = _dot_attr_string( $variables );
1109 $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
1111 foreach my $node ( keys %subend ) {
1112 my $witstr = $self->_path_display_label( $opts,
1113 $self->path_witnesses( $node, $subend{$node} ) );
1114 my $variables = { %edge_attrs, 'label' => $witstr };
1115 my $varopts = _dot_attr_string( $variables );
1116 $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
1119 if( $STRAIGHTENHACK ) {
1120 my $endlabel = $endrank ? '__SUBEND__' : '__END__';
1121 $dot .= "\t\"$endlabel\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
1128 sub _dot_attr_string {
1131 foreach my $k ( sort keys %$hash ) {
1132 my $v = $hash->{$k};
1133 push( @attrs, $k.'="'.$v.'"' );
1135 return( '[ ' . join( ', ', @attrs ) . ' ]' );
1138 sub _add_edge_weights {
1140 # Walk the graph from START to END, choosing the successor node with
1141 # the largest number of witness paths each time.
1143 my $curr = $self->start->id;
1144 my $ranked = $self->end->has_rank;
1145 while( $curr ne $self->end->id ) {
1146 my $rank = $ranked ? $self->reading( $curr )->rank : 0;
1147 my @succ = sort { $self->path_witnesses( $curr, $a )
1148 <=> $self->path_witnesses( $curr, $b ) }
1149 $self->sequence->successors( $curr );
1150 my $next = pop @succ;
1151 my $nextrank = $ranked ? $self->reading( $next )->rank : 0;
1152 # Try to avoid lacunae in the weighted path.
1154 ( $self->reading( $next )->is_lacuna ||
1155 $nextrank - $rank > 1 ) ){
1158 $weighted->{$curr} = $next;
1164 =head2 path_witnesses( $edge )
1166 Returns the list of sigils whose witnesses are associated with the given edge.
1167 The edge can be passed as either an array or an arrayref of ( $source, $target ).
1171 sub path_witnesses {
1172 my( $self, @edge ) = @_;
1173 # If edge is an arrayref, cope.
1174 if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
1175 my $e = shift @edge;
1178 my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
1182 # Helper function. Make a display label for the given witnesses, showing a.c.
1183 # witnesses only where the main witness is not also in the list.
1184 sub _path_display_label {
1188 map { $wits{$_} = 1 } @_;
1190 # If an a.c. wit is listed, remove it if the main wit is also listed.
1191 # Otherwise keep it for explicit listing.
1192 my $aclabel = $self->ac_label;
1194 foreach my $w ( sort keys %wits ) {
1195 if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
1196 if( exists $wits{$1} ) {
1199 push( @disp_ac, $w );
1204 if( $opts->{'explicit_wits'} ) {
1205 return join( ', ', sort keys %wits );
1207 # See if we are in a majority situation.
1208 my $maj = scalar( $self->tradition->witnesses ) * 0.6;
1209 $maj = $maj > 5 ? $maj : 5;
1210 if( scalar keys %wits > $maj ) {
1211 unshift( @disp_ac, 'majority' );
1212 return join( ', ', @disp_ac );
1214 return join( ', ', sort keys %wits );
1219 =head2 readings_at_rank( $rank )
1221 Returns a list of readings at a given rank, taken from the alignment table.
1225 sub readings_at_rank {
1226 my( $self, $rank ) = @_;
1227 my $table = $self->alignment_table;
1228 # Table rank is real rank - 1.
1229 my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
1231 foreach my $e ( @elements ) {
1232 next unless ref( $e ) eq 'HASH';
1233 next unless exists $e->{'t'};
1234 $readings{$e->{'t'}->id} = $e->{'t'};
1236 return values %readings;
1241 Returns a GraphML representation of the collation. The GraphML will contain
1242 two graphs. The first expresses the attributes of the readings and the witness
1243 paths that link them; the second expresses the relationships that link the
1244 readings. This is the native transfer format for a tradition.
1248 use Text::Tradition;
1254 my $datafile = 't/data/florilegium_tei_ps.xml';
1255 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1257 'file' => $datafile,
1260 ok( $tradition, "Got a tradition object" );
1261 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
1262 ok( $tradition->collation, "Tradition has a collation" );
1264 my $c = $tradition->collation;
1265 is( scalar $c->readings, $READINGS, "Collation has all readings" );
1266 is( scalar $c->paths, $PATHS, "Collation has all paths" );
1267 is( scalar $c->relationships, 0, "Collation has all relationships" );
1269 # Add a few relationships
1270 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
1271 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
1272 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition',
1273 'is_significant' => 'yes' } );
1275 # Now write it to GraphML and parse it again.
1277 my $graphml = $c->as_graphml;
1278 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
1279 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
1280 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
1281 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
1282 my $sigrel = $st->collation->get_relationship( 'w257', 'w262' );
1283 is( $sigrel->is_significant, 'yes', "Ternary attribute value was restored" );
1285 # Now add a stemma, write to GraphML, and look at the output.
1287 skip "Analysis module not present", 3 unless $tradition->can( 'add_stemma' );
1288 my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
1289 is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
1290 is( $tradition->stemmata, 1, "Tradition now has the stemma" );
1291 $graphml = $c->as_graphml;
1292 like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
1299 ## TODO MOVE this to Tradition.pm and modularize it better
1301 my( $self, $options ) = @_;
1302 $self->calculate_ranks unless $self->_graphcalc_done;
1304 my $start = $options->{'from'}
1305 ? $self->reading( $options->{'from'} ) : $self->start;
1306 my $end = $options->{'to'}
1307 ? $self->reading( $options->{'to'} ) : $self->end;
1308 if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
1309 throw( 'Start node must be before end node' );
1311 # The readings need to be ranked for this to work.
1312 $start = $self->start unless $start->has_rank;
1313 $end = $self->end unless $end->has_rank;
1315 unless( $start eq $self->start ) {
1316 $rankoffset = $start->rank - 1;
1321 my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
1322 my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
1323 my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
1324 'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
1326 # Create the document and root node
1327 require XML::LibXML;
1328 my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
1329 my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
1330 $graphml->setDocumentElement( $root );
1331 $root->setNamespace( $xsi_ns, 'xsi', 0 );
1332 $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
1334 # List of attribute types to save on our objects and their corresponding
1339 'Bool' => 'boolean',
1340 'ReadingID' => 'string',
1341 'RelationshipType' => 'string',
1342 'RelationshipScope' => 'string',
1343 'Ternary' => 'string',
1346 # Add the data keys for the graph. Include an extra key 'version' for the
1347 # GraphML output version.
1348 my %graph_data_keys;
1350 my %graph_attributes = ( 'version' => 'string' );
1351 # Graph attributes include those of Tradition and those of Collation.
1353 # TODO Use meta introspection method from duplicate_reading to do this
1354 # instead of naming custom keys.
1355 my $tmeta = $self->tradition->meta;
1356 my $cmeta = $self->meta;
1357 map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
1358 map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
1359 foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
1360 next if $attr->name =~ /^_/;
1361 next unless $save_types{$attr->type_constraint->name};
1362 $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1364 # Extra custom keys for complex objects that should be saved in some form.
1365 # The subroutine should return a string, or undef/empty.
1366 if( $tmeta->has_method('stemmata') ) {
1367 $graph_attributes{'stemmata'} = sub {
1369 map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
1370 $self->tradition->stemmata;
1371 join( "\n", @stemstrs );
1375 if( $tmeta->has_method('user') ) {
1376 $graph_attributes{'user'} = sub {
1377 $self->tradition->user ? $self->tradition->user->id : undef
1381 foreach my $datum ( sort keys %graph_attributes ) {
1382 $graph_data_keys{$datum} = 'dg'.$gdi++;
1383 my $key = $root->addNewChild( $graphml_ns, 'key' );
1384 my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
1385 : $graph_attributes{$datum};
1386 $key->setAttribute( 'attr.name', $datum );
1387 $key->setAttribute( 'attr.type', $dtype );
1388 $key->setAttribute( 'for', 'graph' );
1389 $key->setAttribute( 'id', $graph_data_keys{$datum} );
1392 # Add the data keys for reading nodes
1393 my %reading_attributes;
1394 my $rmeta = Text::Tradition::Collation::Reading->meta;
1395 foreach my $attr( $rmeta->get_all_attributes ) {
1396 next if $attr->name =~ /^_/;
1397 next unless $save_types{$attr->type_constraint->name};
1398 $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1400 if( $self->start->does('Text::Tradition::Morphology' ) ) {
1401 # Extra custom key for the reading morphology
1402 $reading_attributes{'lexemes'} = 'string';
1407 foreach my $datum ( sort keys %reading_attributes ) {
1408 $node_data_keys{$datum} = 'dn'.$ndi++;
1409 my $key = $root->addNewChild( $graphml_ns, 'key' );
1410 $key->setAttribute( 'attr.name', $datum );
1411 $key->setAttribute( 'attr.type', $reading_attributes{$datum} );
1412 $key->setAttribute( 'for', 'node' );
1413 $key->setAttribute( 'id', $node_data_keys{$datum} );
1416 # Add the data keys for edges, that is, paths and relationships. Path
1417 # data does not come from a Moose class so is here manually.
1420 my %edge_attributes = (
1421 witness => 'string', # ID/label for a path
1422 extra => 'boolean', # Path key
1424 my @path_attributes = keys %edge_attributes; # track our manual additions
1425 my $pmeta = Text::Tradition::Collation::Relationship->meta;
1426 foreach my $attr( $pmeta->get_all_attributes ) {
1427 next if $attr->name =~ /^_/;
1428 next unless $save_types{$attr->type_constraint->name};
1429 $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1431 foreach my $datum ( sort keys %edge_attributes ) {
1432 $edge_data_keys{$datum} = 'de'.$edi++;
1433 my $key = $root->addNewChild( $graphml_ns, 'key' );
1434 $key->setAttribute( 'attr.name', $datum );
1435 $key->setAttribute( 'attr.type', $edge_attributes{$datum} );
1436 $key->setAttribute( 'for', 'edge' );
1437 $key->setAttribute( 'id', $edge_data_keys{$datum} );
1440 # Add the collation graph itself. First, sanitize the name to a valid XML ID.
1441 my $xmlidname = $self->tradition->name;
1442 $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
1443 if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
1444 $xmlidname = '_'.$xmlidname;
1446 my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
1447 $sgraph->setAttribute( 'edgedefault', 'directed' );
1448 $sgraph->setAttribute( 'id', $xmlidname );
1449 $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
1450 $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
1451 $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
1452 $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
1453 $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
1455 # Tradition/collation attribute data
1456 foreach my $datum ( keys %graph_attributes ) {
1458 if( $datum eq 'version' ) {
1460 } elsif( ref( $graph_attributes{$datum} ) ) {
1461 my $sub = $graph_attributes{$datum};
1463 } elsif( $gattr_from{$datum} eq 'Tradition' ) {
1464 $value = $self->tradition->$datum;
1466 $value = $self->$datum;
1468 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
1473 # Add our readings to the graph
1474 foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
1475 next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
1476 ( $n->rank < $start->rank || $n->rank > $end->rank );
1477 $use_readings{$n->id} = 1;
1478 # Add to the main graph
1479 my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
1480 my $node_xmlid = 'n' . $node_ctr++;
1481 $node_hash{ $n->id } = $node_xmlid;
1482 $node_el->setAttribute( 'id', $node_xmlid );
1483 foreach my $d ( keys %reading_attributes ) {
1485 # Custom serialization
1486 if( $d eq 'lexemes' ) {
1487 # If nval is a true value, we have lexemes so we need to
1488 # serialize them. Otherwise set nval to undef so that the
1489 # key is excluded from this reading.
1490 $nval = $nval ? $n->_serialize_lexemes : undef;
1491 } elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
1494 if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
1495 # Adjust the ranks within the subgraph.
1496 $nval = $n eq $self->end ? $end->rank - $rankoffset + 1
1497 : $nval - $rankoffset;
1499 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
1504 # Add the path edges to the sequence graph
1506 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
1507 # We add an edge in the graphml for every witness in $e.
1508 next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
1509 my @edge_wits = sort $self->path_witnesses( $e );
1510 $e->[0] = $self->start->id unless $use_readings{$e->[0]};
1511 $e->[1] = $self->end->id unless $use_readings{$e->[1]};
1512 # Skip any path from start to end; that witness is not in the subgraph.
1513 next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
1514 foreach my $wit ( @edge_wits ) {
1515 my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
1516 $node_hash{ $e->[0] },
1517 $node_hash{ $e->[1] } );
1518 my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
1519 $edge_el->setAttribute( 'source', $from );
1520 $edge_el->setAttribute( 'target', $to );
1521 $edge_el->setAttribute( 'id', $id );
1523 # It's a witness path, so add the witness
1525 my $key = $edge_data_keys{'witness'};
1526 # Is this an ante-corr witness?
1527 my $aclabel = $self->ac_label;
1528 if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
1529 # Keep the base witness
1531 # ...and record that this is an 'extra' reading path
1532 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
1534 _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
1538 # Report the actual number of nodes and edges that went in
1539 $sgraph->setAttribute( 'parse.edges', $edge_ctr );
1540 $sgraph->setAttribute( 'parse.nodes', $node_ctr );
1542 # Add the relationship graph to the XML
1543 map { delete $edge_data_keys{$_} } @path_attributes;
1544 $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
1545 $node_data_keys{'id'}, \%edge_data_keys );
1547 # Save and return the thing
1548 my $result = decode_utf8( $graphml->toString(1) );
1552 sub _add_graphml_data {
1553 my( $el, $key, $value ) = @_;
1554 return unless defined $value;
1555 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1556 $data_el->setAttribute( 'key', $key );
1557 $data_el->appendText( $value );
1562 Returns a CSV alignment table representation of the collation graph, one
1563 row per witness (or witness uncorrected.)
1567 Returns a tab-separated alignment table representation of the collation graph,
1568 one row per witness (or witness uncorrected.)
1572 use Text::Tradition;
1580 my $datafile = 't/data/florilegium_tei_ps.xml';
1581 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1583 'file' => $datafile,
1586 my $c = $tradition->collation;
1587 # Export the thing to CSV
1588 my $csvstr = $c->as_csv();
1590 my $csv = Text::CSV->new({ sep_char => ',', binary => 1 });
1591 my @lines = split(/\n/, $csvstr );
1592 ok( $csv->parse( $lines[0] ), "Successfully parsed first line of CSV" );
1593 is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness columns" );
1594 my @q_ac = grep { $_ eq 'Q'.$c->ac_label } $csv->fields;
1595 ok( @q_ac, "Found a layered witness" );
1597 my $t2 = Text::Tradition->new( input => 'Tabular',
1601 is( scalar $t2->collation->readings, $READINGS, "Reparsed CSV collation has all readings" );
1602 is( scalar $t2->collation->paths, $PATHS, "Reparsed CSV collation has all paths" );
1604 # Now do it with TSV
1605 my $tsvstr = $c->as_tsv();
1606 my $t3 = Text::Tradition->new( input => 'Tabular',
1610 is( scalar $t3->collation->readings, $READINGS, "Reparsed TSV collation has all readings" );
1611 is( scalar $t3->collation->paths, $PATHS, "Reparsed TSV collation has all paths" );
1613 my $table = $c->alignment_table;
1614 my $noaccsv = $c->as_csv({ noac => 1 });
1615 my @noaclines = split(/\n/, $noaccsv );
1616 ok( $csv->parse( $noaclines[0] ), "Successfully parsed first line of no-ac CSV" );
1617 is( scalar( $csv->fields ), $WITS, "CSV has correct number of witness columns" );
1618 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
1620 my $safecsv = $c->as_csv({ safe_ac => 1});
1621 my @safelines = split(/\n/, $safecsv );
1622 ok( $csv->parse( $safelines[0] ), "Successfully parsed first line of safe CSV" );
1623 is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness columns" );
1624 @q_ac = grep { $_ eq 'Q__L' } $csv->fields;
1625 ok( @q_ac, "Found a sanitized layered witness" );
1626 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
1633 my( $self, $opts ) = @_;
1634 my $table = $self->alignment_table( $opts );
1635 my $csv_options = { binary => 1, quote_null => 0 };
1636 $csv_options->{'sep_char'} = $opts->{fieldsep};
1637 if( $opts->{fieldsep} eq "\t" ) {
1638 # If it is really tab separated, nothing is an escape char.
1639 $csv_options->{'quote_char'} = undef;
1640 $csv_options->{'escape_char'} = '';
1642 my $csv = Text::CSV->new( $csv_options );
1644 # Make the header row
1645 $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
1646 push( @result, $csv->string );
1647 # Make the rest of the rows
1648 foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1649 my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
1650 my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
1651 $csv->combine( @row );
1652 push( @result, $csv->string );
1654 return join( "\n", @result );
1659 my $opts = shift || {};
1660 $opts->{fieldsep} = ',';
1661 return $self->_tabular( $opts );
1666 my $opts = shift || {};
1667 $opts->{fieldsep} = "\t";
1668 return $self->_tabular( $opts );
1671 =head2 alignment_table
1673 Return a reference to an alignment table, in a slightly enhanced CollateX
1674 format which looks like this:
1676 $table = { alignment => [ { witness => "SIGIL",
1677 tokens => [ { t => "TEXT" }, ... ] },
1678 { witness => "SIG2",
1679 tokens => [ { t => "TEXT" }, ... ] },
1681 length => TEXTLEN };
1685 sub alignment_table {
1686 my( $self, $opts ) = @_;
1687 if( $self->has_cached_table ) {
1688 return $self->cached_table
1689 unless $opts->{noac} || $opts->{safe_ac};
1692 # Make sure we can do this
1693 throw( "Need a linear graph in order to make an alignment table" )
1694 unless $self->linear;
1695 $self->calculate_ranks()
1696 unless $self->_graphcalc_done && $self->end->has_rank;
1698 my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1699 my @all_pos = ( 1 .. $self->end->rank - 1 );
1700 foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1701 # say STDERR "Making witness row(s) for " . $wit->sigil;
1702 my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1703 my @row = _make_witness_row( \@wit_path, \@all_pos );
1704 my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
1705 $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
1706 push( @{$table->{'alignment'}}, $witobj );
1707 if( $wit->is_layered && !$opts->{noac} ) {
1708 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1709 $wit->sigil.$self->ac_label );
1710 my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1711 my $witlabel = $opts->{safe_ac}
1712 ? $wit->sigil . '__L' : $wit->sigil.$self->ac_label;
1713 my $witacobj = { 'witness' => $witlabel,
1714 'tokens' => \@ac_row };
1715 $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
1716 push( @{$table->{'alignment'}}, $witacobj );
1719 unless( $opts->{noac} || $opts->{safe_ac} ) {
1720 $self->cached_table( $table );
1725 sub _make_witness_row {
1726 my( $path, $positions ) = @_;
1728 map { $char_hash{$_} = undef } @$positions;
1730 foreach my $rdg ( @$path ) {
1731 say STDERR "rank " . $rdg->rank if $debug;
1732 # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1733 $char_hash{$rdg->rank} = { 't' => $rdg };
1735 my @row = map { $char_hash{$_} } @$positions;
1736 # Fill in lacuna markers for undef spots in the row
1737 my $last_el = shift @row;
1738 my @filled_row = ( $last_el );
1739 foreach my $el ( @row ) {
1740 # If we are using node reference, make the lacuna node appear many times
1741 # in the table. If not, use the lacuna tag.
1742 if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1745 push( @filled_row, $el );
1752 =head1 NAVIGATION METHODS
1754 =head2 reading_sequence( $first, $last, $sigil, $backup )
1756 Returns the ordered list of readings, starting with $first and ending
1757 with $last, for the witness given in $sigil. If a $backup sigil is
1758 specified (e.g. when walking a layered witness), it will be used wherever
1759 no $sigil path exists. If there is a base text reading, that will be
1760 used wherever no path exists for $sigil or $backup.
1764 # TODO Think about returning some lazy-eval iterator.
1765 # TODO Get rid of backup; we should know from what witness is whether we need it.
1767 sub reading_sequence {
1768 my( $self, $start, $end, $witness ) = @_;
1770 $witness = $self->baselabel unless $witness;
1771 my @readings = ( $start );
1774 while( $n && $n->id ne $end->id ) {
1775 if( exists( $seen{$n->id} ) ) {
1776 throw( "Detected loop for $witness at " . $n->id );
1780 my $next = $self->next_reading( $n, $witness );
1782 throw( "Did not find any path for $witness from reading " . $n->id );
1784 push( @readings, $next );
1787 # Check that the last reading is our end reading.
1788 my $last = $readings[$#readings];
1789 throw( "Last reading found from " . $start->text .
1790 " for witness $witness is not the end!" ) # TODO do we get this far?
1791 unless $last->id eq $end->id;
1796 =head2 next_reading( $reading, $sigil );
1798 Returns the reading that follows the given reading along the given witness
1804 # Return the successor via the corresponding path.
1806 my $answer = $self->_find_linked_reading( 'next', @_ );
1807 return undef unless $answer;
1808 return $self->reading( $answer );
1811 =head2 prior_reading( $reading, $sigil )
1813 Returns the reading that precedes the given reading along the given witness
1819 # Return the predecessor via the corresponding path.
1821 my $answer = $self->_find_linked_reading( 'prior', @_ );
1822 return $self->reading( $answer );
1825 sub _find_linked_reading {
1826 my( $self, $direction, $node, $path ) = @_;
1828 # Get a backup if we are dealing with a layered witness
1830 my $aclabel = $self->ac_label;
1831 if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1835 my @linked_paths = $direction eq 'next'
1836 ? $self->sequence->edges_from( $node )
1837 : $self->sequence->edges_to( $node );
1838 return undef unless scalar( @linked_paths );
1840 # We have to find the linked path that contains all of the
1841 # witnesses supplied in $path.
1842 my( @path_wits, @alt_path_wits );
1843 @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1844 @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1847 foreach my $le ( @linked_paths ) {
1848 if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1851 my @le_wits = sort $self->path_witnesses( $le );
1852 if( _is_within( \@path_wits, \@le_wits ) ) {
1853 # This is the right path.
1854 return $direction eq 'next' ? $le->[1] : $le->[0];
1855 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1859 # Got this far? Return the alternate path if it exists.
1860 return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1863 # Got this far? Return the base path if it exists.
1864 return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1867 # Got this far? We have no appropriate path.
1868 warn "Could not find $direction node from " . $node->id
1869 . " along path $path";
1875 my( $set1, $set2 ) = @_;
1876 my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1877 foreach my $el ( @$set1 ) {
1878 $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1883 # Return the string that joins together a list of witnesses for
1884 # display on a single path.
1885 sub _witnesses_of_label {
1886 my( $self, $label ) = @_;
1887 my $regex = $self->wit_list_separator;
1888 my @answer = split( /\Q$regex\E/, $label );
1892 =head2 common_readings
1894 Returns the list of common readings in the graph (i.e. those readings that are
1895 shared by all non-lacunose witnesses.)
1899 sub common_readings {
1901 my @common = grep { $_->is_common } $self->readings;
1905 =head2 path_text( $sigil, [, $start, $end ] )
1907 Returns the text of a witness (plus its backup, if we are using a layer)
1908 as stored in the collation. The text is returned as a string, where the
1909 individual readings are joined with spaces and the meta-readings (e.g.
1910 lacunae) are omitted. Optional specification of $start and $end allows
1911 the generation of a subset of the witness text.
1916 my( $self, $wit, $start, $end ) = @_;
1917 $start = $self->start unless $start;
1918 $end = $self->end unless $end;
1919 my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1922 foreach my $r ( @path ) {
1923 unless ( $r->join_prior || !$last || $last->join_next ) {
1926 $pathtext .= $r->text;
1932 =head1 INITIALIZATION METHODS
1934 These are mostly for use by parsers.
1936 =head2 make_witness_path( $witness )
1938 Link the array of readings contained in $witness->path (and in
1939 $witness->uncorrected_path if it exists) into collation paths.
1940 Clear out the arrays when finished.
1942 =head2 make_witness_paths
1944 Call make_witness_path for all witnesses in the tradition.
1948 # For use when a collation is constructed from a base text and an apparatus.
1949 # We have the sequences of readings and just need to add path edges.
1950 # When we are done, clear out the witness path attributes, as they are no
1952 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1954 sub make_witness_paths {
1956 foreach my $wit ( $self->tradition->witnesses ) {
1957 # say STDERR "Making path for " . $wit->sigil;
1958 $self->make_witness_path( $wit );
1962 sub make_witness_path {
1963 my( $self, $wit ) = @_;
1964 my @chain = @{$wit->path};
1965 my $sig = $wit->sigil;
1966 # Add start and end if necessary
1967 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1968 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1969 foreach my $idx ( 0 .. $#chain-1 ) {
1970 $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1972 if( $wit->is_layered ) {
1973 @chain = @{$wit->uncorrected_path};
1974 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1975 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1976 foreach my $idx( 0 .. $#chain-1 ) {
1977 my $source = $chain[$idx];
1978 my $target = $chain[$idx+1];
1979 $self->add_path( $source, $target, $sig.$self->ac_label )
1980 unless $self->has_path( $source, $target, $sig );
1984 $wit->clear_uncorrected_path;
1987 =head2 calculate_ranks
1989 Calculate the reading ranks (that is, their aligned positions relative
1990 to each other) for the graph. This can only be called on linear collations.
1994 use Text::Tradition;
1996 my $cxfile = 't/data/Collatex-16.xml';
1997 my $t = Text::Tradition->new(
1999 'input' => 'CollateX',
2002 my $c = $t->collation;
2005 my $table = $c->alignment_table;
2006 ok( $c->has_cached_table, "Alignment table was cached" );
2007 is( $c->alignment_table, $table, "Cached table returned upon second call" );
2008 $c->calculate_ranks;
2009 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
2010 $c->add_relationship( 'n13', 'n23', { type => 'repetition' } );
2011 is( $c->alignment_table, $table, "Alignment table unchanged after non-colo relationship add" );
2012 $c->add_relationship( 'n24', 'n23', { type => 'spelling' } );
2013 isnt( $c->alignment_table, $table, "Alignment table changed after colo relationship add" );
2019 sub calculate_ranks {
2021 # Save the existing ranks, in case we need to invalidate the cached SVG.
2022 throw( "Cannot calculate ranks on a non-linear graph" )
2023 unless $self->linear;
2025 map { $existing_ranks{$_} = $_->rank } $self->readings;
2027 # Do the rankings based on the relationship equivalence graph, starting
2028 # with the start node.
2029 my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
2031 # Transfer our rankings from the topological graph to the real one.
2032 foreach my $r ( $self->readings ) {
2033 if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
2034 $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
2036 # Die. Find the last rank we calculated.
2037 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
2038 <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
2040 my $last = pop @all_defined;
2041 throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
2044 # Do we need to invalidate the cached data?
2045 if( $self->has_cached_table ) {
2046 foreach my $r ( $self->readings ) {
2047 next if defined( $existing_ranks{$r} )
2048 && $existing_ranks{$r} == $r->rank;
2049 # Something has changed, so clear the cache
2050 $self->_clear_cache;
2051 # ...and recalculate the common readings.
2052 $self->calculate_common_readings();
2056 # The graph calculation information is now up to date.
2057 $self->_graphcalc_done(1);
2062 $self->wipe_table if $self->has_cached_table;
2066 =head2 flatten_ranks
2068 A convenience method for parsing collation data. Searches the graph for readings
2069 with the same text at the same rank, and merges any that are found.
2074 my ( $self, %args ) = shift;
2075 my %unique_rank_rdg;
2077 foreach my $p ( $self->identical_readings( %args ) ) {
2078 # say STDERR "Combining readings at same rank: @$p";
2080 $self->merge_readings( @$p );
2081 # TODO see if this now makes a common point.
2083 # If we merged readings, the ranks are still fine but the alignment
2084 # table is wrong. Wipe it.
2085 $self->wipe_table() if $changed;
2088 =head2 identical_readings
2089 =head2 identical_readings( start => $startnode, end => $endnode )
2090 =head2 identical_readings( startrank => $startrank, endrank => $endrank )
2092 Goes through the graph identifying all pairs of readings that appear to be
2093 identical, and therefore able to be merged into a single reading. Returns the
2094 relevant identical pairs. Can be restricted to run over only a part of the
2095 graph, specified either by node or by rank.
2099 sub identical_readings {
2100 my ( $self, %args ) = @_;
2101 # Find where we should start and end.
2102 my $startrank = $args{startrank} || 0;
2103 if( $args{start} ) {
2104 throw( "Starting reading has no rank" ) unless $self->reading( $args{start} )
2105 && $self->reading( $args{start} )->has_rank;
2106 $startrank = $self->reading( $args{start} )->rank;
2108 my $endrank = $args{endrank} || $self->end->rank;
2110 throw( "Ending reading has no rank" ) unless $self->reading( $args{end} )
2111 && $self->reading( $args{end} )->has_rank;
2112 $endrank = $self->reading( $args{end} )->rank;
2115 # Make sure the ranks are correct.
2116 unless( $self->_graphcalc_done ) {
2117 $self->calculate_ranks;
2119 # Go through the readings looking for duplicates.
2120 my %unique_rank_rdg;
2122 foreach my $rdg ( $self->readings ) {
2123 next unless $rdg->has_rank;
2124 my $rk = $rdg->rank;
2125 next if $rk > $endrank || $rk < $startrank;
2126 my $key = $rk . "||" . $rdg->text;
2127 if( exists $unique_rank_rdg{$key} ) {
2128 # Make sure they don't have different grammatical forms
2129 my $ur = $unique_rank_rdg{$key};
2130 if( $rdg->is_identical( $ur ) ) {
2131 push( @pairs, [ $ur, $rdg ] );
2134 $unique_rank_rdg{$key} = $rdg;
2142 =head2 calculate_common_readings
2144 Goes through the graph identifying the readings that appear in every witness
2145 (apart from those with lacunae at that spot.) Marks them as common and returns
2150 use Text::Tradition;
2152 my $cxfile = 't/data/Collatex-16.xml';
2153 my $t = Text::Tradition->new(
2155 'input' => 'CollateX',
2158 my $c = $t->collation;
2160 my @common = $c->calculate_common_readings();
2161 is( scalar @common, 8, "Found correct number of common readings" );
2162 my @marked = sort $c->common_readings();
2163 is( scalar @common, 8, "All common readings got marked as such" );
2164 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
2165 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
2171 sub calculate_common_readings {
2174 map { $_->is_common( 0 ) } $self->readings;
2175 # Implicitly calls calculate_ranks
2176 my $table = $self->alignment_table;
2177 foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
2178 my @row = map { $_->{'tokens'}->[$idx]
2179 ? $_->{'tokens'}->[$idx]->{'t'} : '' }
2180 @{$table->{'alignment'}};
2182 foreach my $r ( @row ) {
2184 $hash{$r->id} = $r unless $r->is_meta;
2186 $hash{'UNDEF'} = $r;
2189 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
2190 my( $r ) = values %hash;
2192 push( @common, $r );
2198 =head2 text_from_paths
2200 Calculate the text array for all witnesses from the path, for later consistency
2201 checking. Only to be used if there is no non-graph-based way to know the
2206 sub text_from_paths {
2208 foreach my $wit ( $self->tradition->witnesses ) {
2209 my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
2211 foreach my $r ( @readings ) {
2212 next if $r->is_meta;
2213 push( @text, $r->text );
2215 $wit->text( \@text );
2216 if( $wit->is_layered ) {
2217 my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
2218 $wit->sigil.$self->ac_label );
2220 foreach my $r ( @ucrdgs ) {
2221 next if $r->is_meta;
2222 push( @uctext, $r->text );
2224 $wit->layertext( \@uctext );
2229 =head1 UTILITY FUNCTIONS
2231 =head2 common_predecessor( $reading_a, $reading_b )
2233 Find the last reading that occurs in sequence before both the given readings.
2234 At the very least this should be $self->start.
2236 =head2 common_successor( $reading_a, $reading_b )
2238 Find the first reading that occurs in sequence after both the given readings.
2239 At the very least this should be $self->end.
2243 use Text::Tradition;
2245 my $cxfile = 't/data/Collatex-16.xml';
2246 my $t = Text::Tradition->new(
2248 'input' => 'CollateX',
2251 my $c = $t->collation;
2253 is( $c->common_predecessor( 'n24', 'n23' )->id,
2254 'n20', "Found correct common predecessor" );
2255 is( $c->common_successor( 'n24', 'n23' )->id,
2256 '__END__', "Found correct common successor" );
2258 is( $c->common_predecessor( 'n19', 'n17' )->id,
2259 'n16', "Found correct common predecessor for readings on same path" );
2260 is( $c->common_successor( 'n21', 'n10' )->id,
2261 '__END__', "Found correct common successor for readings on same path" );
2267 ## Return the closest reading that is a predecessor of both the given readings.
2268 sub common_predecessor {
2270 my( $r1, $r2 ) = $self->_objectify_args( @_ );
2271 return $self->_common_in_path( $r1, $r2, 'predecessors' );
2274 sub common_successor {
2276 my( $r1, $r2 ) = $self->_objectify_args( @_ );
2277 return $self->_common_in_path( $r1, $r2, 'successors' );
2281 # TODO think about how to do this without ranks...
2282 sub _common_in_path {
2283 my( $self, $r1, $r2, $dir ) = @_;
2284 my $iter = $self->end->rank;
2286 my @last_r1 = ( $r1 );
2287 my @last_r2 = ( $r2 );
2288 # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
2290 # say STDERR "Finding common $dir for $r1, $r2";
2291 while( !@candidates ) {
2292 last unless $iter--; # Avoid looping infinitely
2293 # Iterate separately down the graph from r1 and r2
2294 my( @new_lc1, @new_lc2 );
2295 foreach my $lc ( @last_r1 ) {
2296 foreach my $p ( $lc->$dir ) {
2297 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
2298 # say STDERR "Path candidate $p from $lc";
2299 push( @candidates, $p );
2300 } elsif( !$all_seen{$p->id} ) {
2301 $all_seen{$p->id} = 'r1';
2302 push( @new_lc1, $p );
2306 foreach my $lc ( @last_r2 ) {
2307 foreach my $p ( $lc->$dir ) {
2308 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
2309 # say STDERR "Path candidate $p from $lc";
2310 push( @candidates, $p );
2311 } elsif( !$all_seen{$p->id} ) {
2312 $all_seen{$p->id} = 'r2';
2313 push( @new_lc2, $p );
2317 @last_r1 = @new_lc1;
2318 @last_r2 = @new_lc2;
2320 my @answer = sort { $a->rank <=> $b->rank } @candidates;
2321 return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
2325 Text::Tradition::Error->throw(
2326 'ident' => 'Collation error',
2332 __PACKAGE__->meta->make_immutable;
2338 =item * Rework XML serialization in a more modular way
2344 This package is free software and is provided "as is" without express
2345 or implied warranty. You can redistribute it and/or modify it under
2346 the same terms as Perl itself.
2350 Tara L Andrews E<lt>aurum@cpan.orgE<gt>