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 ### Reading construct/destruct functions
239 my( $self, $reading ) = @_;
240 unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
241 my %args = %$reading;
242 if( $args{'init'} ) {
243 # If we are initializing an empty collation, don't assume that we
244 # have set a tradition.
245 delete $args{'init'};
246 } elsif( $self->tradition->can('language') && $self->tradition->has_language
247 && !exists $args{'language'} ) {
248 $args{'language'} = $self->tradition->language;
250 $reading = Text::Tradition::Collation::Reading->new(
251 'collation' => $self,
254 # First check to see if a reading with this ID exists.
255 if( $self->reading( $reading->id ) ) {
256 throw( "Collation already has a reading with id " . $reading->id );
258 $self->_graphcalc_done(0);
259 $self->_add_reading( $reading->id => $reading );
260 # Once the reading has been added, put it in both graphs.
261 $self->sequence->add_vertex( $reading->id );
262 $self->relations->add_reading( $reading->id );
266 around del_reading => sub {
271 if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
274 # Remove the reading from the graphs.
275 $self->_graphcalc_done(0);
276 $self->_clear_cache; # Explicitly clear caches to GC the reading
277 $self->sequence->delete_vertex( $arg );
278 $self->relations->delete_reading( $arg );
281 $self->$orig( $arg );
284 =head2 merge_readings( $main, $second, $concatenate, $with_str )
286 Merges the $second reading into the $main one. If $concatenate is true, then
287 the merged node will carry the text of both readings, concatenated with either
288 $with_str (if specified) or a sensible default (the empty string if the
289 appropriate 'join_*' flag is set on either reading, or else $self->wordsep.)
291 The first two arguments may be either readings or reading IDs.
297 my $cxfile = 't/data/Collatex-16.xml';
298 my $t = Text::Tradition->new(
300 'input' => 'CollateX',
303 my $c = $t->collation;
305 my $rno = scalar $c->readings;
306 # Split n21 ('unto') for testing purposes
307 my $new_r = $c->add_reading( { 'id' => 'n21p0', 'text' => 'un', 'join_next' => 1 } );
308 my $old_r = $c->reading( 'n21' );
309 $old_r->alter_text( 'to' );
310 $c->del_path( 'n20', 'n21', 'A' );
311 $c->add_path( 'n20', 'n21p0', 'A' );
312 $c->add_path( 'n21p0', 'n21', 'A' );
313 $c->add_relationship( 'n21', 'n22', { type => 'collated', scope => 'local' } );
315 ok( $c->reading( 'n21p0' ), "New reading exists" );
316 is( scalar $c->readings, $rno, "Reading add offset by flatten_ranks" );
318 # Combine n3 and n4 ( with his )
319 $c->merge_readings( 'n3', 'n4', 1 );
320 ok( !$c->reading('n4'), "Reading n4 is gone" );
321 is( $c->reading('n3')->text, 'with his', "Reading n3 has both words" );
323 # Collapse n9 and n10 ( rood / root )
324 $c->merge_readings( 'n9', 'n10' );
325 ok( !$c->reading('n10'), "Reading n10 is gone" );
326 is( $c->reading('n9')->text, 'rood', "Reading n9 has an unchanged word" );
328 # Combine n21 and n21p0
329 my $remaining = $c->reading('n21');
330 $remaining ||= $c->reading('n22'); # one of these should still exist
331 $c->merge_readings( 'n21p0', $remaining, 1 );
332 ok( !$c->reading('n21'), "Reading $remaining is gone" );
333 is( $c->reading('n21p0')->text, 'unto', "Reading n21p0 merged correctly" );
343 my( $kept_obj, $del_obj, $combine, $combine_char ) = $self->_objectify_args( @_ );
344 my $mergemeta = $kept_obj->is_meta;
345 throw( "Cannot merge meta and non-meta reading" )
346 unless ( $mergemeta && $del_obj->is_meta )
347 || ( !$mergemeta && !$del_obj->is_meta );
349 throw( "Cannot merge with start or end node" )
350 if( $kept_obj eq $self->start || $kept_obj eq $self->end
351 || $del_obj eq $self->start || $del_obj eq $self->end );
352 throw( "Cannot combine text of meta readings" ) if $combine;
354 # We only need the IDs for adding paths to the graph, not the reading
355 # objects themselves.
356 my $kept = $kept_obj->id;
357 my $deleted = $del_obj->id;
358 $self->_graphcalc_done(0);
360 # The kept reading should inherit the paths and the relationships
361 # of the deleted reading.
362 foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
363 my @vector = ( $kept );
364 push( @vector, $path->[1] ) if $path->[0] eq $deleted;
365 unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
366 next if $vector[0] eq $vector[1]; # Don't add a self loop
367 my %wits = %{$self->sequence->get_edge_attributes( @$path )};
368 $self->sequence->add_edge( @vector );
369 my $fwits = $self->sequence->get_edge_attributes( @vector );
370 @wits{keys %$fwits} = values %$fwits;
371 $self->sequence->set_edge_attributes( @vector, \%wits );
373 $self->relations->merge_readings( $kept, $deleted, $combine );
375 # Do the deletion deed.
377 # Combine the text of the readings
378 my $joinstr = $combine_char;
379 unless( defined $joinstr ) {
380 $joinstr = '' if $kept_obj->join_next || $del_obj->join_prior;
381 $joinstr = $self->wordsep unless defined $joinstr;
383 $kept_obj->_combine( $del_obj, $joinstr );
385 $self->del_reading( $deleted );
388 =head2 compress_readings
390 Where possible in the graph, compresses plain sequences of readings into a
391 single reading. The sequences must consist of readings with no
392 relationships to other readings, with only a single witness path between
393 them and no other witness paths from either that would skip the other. The
394 readings must also not be marked as nonsense or bad grammar.
396 WARNING: This operation cannot be undone.
400 sub compress_readings {
402 # Anywhere in the graph that there is a reading that joins only to a single
403 # successor, and neither of these have any relationships, just join the two
405 foreach my $rdg ( sort { $a->rank <=> $b->rank } $self->readings ) {
406 # Now look for readings that can be joined to their successors.
407 next unless $rdg->is_combinable;
409 while( $self->sequence->successors( $rdg ) == 1 ) {
410 my( $next ) = $self->reading( $self->sequence->successors( $rdg ) );
411 throw( "Infinite loop" ) if $seen{$next->id};
412 $seen{$next->id} = 1;
413 last if $self->sequence->predecessors( $next ) > 1;
414 last unless $next->is_combinable;
415 say "Joining readings $rdg and $next";
416 $self->merge_readings( $rdg, $next, 1 );
419 # Make sure we haven't screwed anything up
420 foreach my $wit ( $self->tradition->witnesses ) {
421 my $pathtext = $self->path_text( $wit->sigil );
422 my $origtext = join( ' ', @{$wit->text} );
423 throw( "Text differs for witness " . $wit->sigil )
424 unless $pathtext eq $origtext;
425 if( $wit->is_layered ) {
426 $pathtext = $self->path_text( $wit->sigil.$self->ac_label );
427 $origtext = join( ' ', @{$wit->layertext} );
428 throw( "Ante-corr text differs for witness " . $wit->sigil )
429 unless $pathtext eq $origtext;
433 $self->relations->rebuild_equivalence();
434 $self->calculate_ranks();
437 # Helper function for manipulating the graph.
438 sub _stringify_args {
439 my( $self, $first, $second, @args ) = @_;
441 if ref( $first ) eq 'Text::Tradition::Collation::Reading';
442 $second = $second->id
443 if ref( $second ) eq 'Text::Tradition::Collation::Reading';
444 return( $first, $second, @args );
447 # Helper function for manipulating the graph.
448 sub _objectify_args {
449 my( $self, $first, $second, $arg ) = @_;
450 $first = $self->reading( $first )
451 unless ref( $first ) eq 'Text::Tradition::Collation::Reading';
452 $second = $self->reading( $second )
453 unless ref( $second ) eq 'Text::Tradition::Collation::Reading';
454 return( $first, $second, $arg );
457 =head2 duplicate_reading( $reading, @witlist )
459 Split the given reading into two, so that the new reading is in the path for
460 the witnesses given in @witlist. If the result is that certain non-colocated
461 relationships (e.g. transpositions) are no longer valid, these will be removed.
462 Returns the newly-created reading.
468 my $st = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/collatecorr.xml' );
469 is( ref( $st ), 'Text::Tradition', "Got a tradition from test file" );
470 ok( $st->has_witness('Ba96'), "Tradition has the affected witness" );
472 my $sc = $st->collation;
474 ok( $sc->reading('n131'), "Tradition has the affected reading" );
475 is( scalar( $sc->readings ), $numr, "There are $numr readings in the graph" );
476 is( $sc->end->rank, 14, "There are fourteen ranks in the graph" );
478 # Detach the erroneously collated reading
479 my( $newr, @del_rdgs ) = $sc->duplicate_reading( 'n131', 'Ba96' );
480 ok( $newr, "New reading was created" );
481 ok( $sc->reading('n131_0'), "Detached the bad collation with a new reading" );
482 is( scalar( $sc->readings ), $numr + 1, "A reading was added to the graph" );
483 is( $sc->end->rank, 10, "There are now only ten ranks in the graph" );
484 my $csucc = $sc->common_successor( 'n131', 'n131_0' );
485 is( $csucc->id, 'n136', "Found correct common successor to duped reading" );
487 # Check that the bad transposition is gone
488 is( scalar @del_rdgs, 1, "Deleted reading was returned by API call" );
489 is( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
491 # The collation should not be fixed
492 my @pairs = $sc->identical_readings();
493 is( scalar @pairs, 0, "Not re-collated yet" );
495 ok( $sc->merge_readings( 'n124', 'n131_0' ), "Collated the readings correctly" );
496 @pairs = $sc->identical_readings( start => 'n124', end => $csucc->id );
497 is( scalar @pairs, 3, "Found three more identical readings" );
498 is( $sc->end->rank, 11, "The ranks shifted appropriately" );
499 $sc->flatten_ranks();
500 is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
506 sub duplicate_reading {
507 my( $self, $r, @wits ) = @_;
508 # Add the new reading, duplicating $r.
509 unless( ref( $r ) eq 'Text::Tradition::Collation::Reading' ) {
510 $r = $self->reading( $r );
512 throw( "Cannot duplicate a meta-reading" )
515 # Get all the reading attributes and duplicate them.
516 my $rmeta = Text::Tradition::Collation::Reading->meta;
518 foreach my $attr( $rmeta->get_all_attributes ) {
519 next if $attr->name =~ /^_/;
520 my $acc = $attr->get_read_method;
521 if( !$acc && $attr->has_applied_traits ) {
522 my $tr = $attr->applied_traits;
523 if( $tr->[0] =~ /::(Array|Hash)$/ ) {
525 my %methods = reverse %{$attr->handles};
526 $acc = $methods{elements};
527 $args{$attr->name} = $which eq 'Array'
528 ? [ $r->$acc ] : { $r->$acc };
531 $args{$attr->name} = $r->$acc if $acc;
534 # By definition the new reading will no longer be common.
535 $args{is_common} = 0;
536 # The new reading also needs its own ID.
537 $args{id} = $self->_generate_dup_id( $r->id );
539 # Try to make the new reading.
540 my $newr = $self->add_reading( \%args );
541 # The old reading is also no longer common.
544 # For each of the witnesses, dissociate from the old reading and
545 # associate with the new.
546 foreach my $wit ( @wits ) {
547 my $prior = $self->prior_reading( $r, $wit );
548 my $next = $self->next_reading( $r, $wit );
549 $self->del_path( $prior, $r, $wit );
550 $self->add_path( $prior, $newr, $wit );
551 $self->del_path( $r, $next, $wit );
552 $self->add_path( $newr, $next, $wit );
555 # If the graph is ranked, we need to look for relationships that are now
556 # invalid (i.e. 'non-colocation' types that might now be colocated) and
557 # remove them. If not, we can skip it.
560 my @deleted_relations;
561 if( $self->end->has_rank ) {
562 # Find the point where we can stop checking
563 $succ = $self->common_successor( $r, $newr );
565 # Hash the existing ranks
566 foreach my $rdg ( $self->readings ) {
567 $rrk{$rdg->id} = $rdg->rank;
569 # Calculate the new ranks
570 $self->calculate_ranks();
572 # Check for invalid non-colocated relationships among changed-rank readings
573 # from where the ranks start changing up to $succ
574 my $lastrank = $succ->rank;
575 foreach my $rdg ( $self->readings ) {
576 next if $rdg->rank > $lastrank;
577 next if $rdg->rank == $rrk{$rdg->id};
578 my @noncolo = $rdg->related_readings( sub { !$_[0]->colocated } );
579 next unless @noncolo;
580 foreach my $nc ( @noncolo ) {
581 unless( $self->relations->verify_or_delete( $rdg, $nc ) ) {
582 push( @deleted_relations, [ $rdg->id, $nc->id ] );
587 return ( $newr, @deleted_relations );
590 sub _generate_dup_id {
591 my( $self, $rid ) = @_;
596 if( $self->has_reading( $newid ) ) {
609 # We only need the IDs for adding paths to the graph, not the reading
610 # objects themselves.
611 my( $source, $target, $wit ) = $self->_stringify_args( @_ );
613 $self->_graphcalc_done(0);
614 # Connect the readings
615 unless( $self->sequence->has_edge( $source, $target ) ) {
616 $self->sequence->add_edge( $source, $target );
617 $self->relations->add_equivalence_edge( $source, $target );
619 # Note the witness in question
620 $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
626 if( ref( $_[0] ) eq 'ARRAY' ) {
633 # We only need the IDs for removing paths from the graph, not the reading
634 # objects themselves.
635 my( $source, $target, $wit ) = $self->_stringify_args( @args );
637 $self->_graphcalc_done(0);
638 if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
639 $self->sequence->delete_edge_attribute( $source, $target, $wit );
641 unless( $self->sequence->has_edge_attributes( $source, $target ) ) {
642 $self->sequence->delete_edge( $source, $target );
643 $self->relations->delete_equivalence_edge( $source, $target );
648 # Extra graph-alike utility
651 my( $source, $target, $wit ) = $self->_stringify_args( @_ );
652 return undef unless $self->sequence->has_edge( $source, $target );
653 return $self->sequence->has_edge_attribute( $source, $target, $wit );
656 =head2 clear_witness( @sigil_list )
658 Clear the given witnesses out of the collation entirely, removing references
659 to them in paths, and removing readings that belong only to them. Should only
660 be called via $tradition->del_witness.
665 my( $self, @sigils ) = @_;
667 $self->_graphcalc_done(0);
668 # Clear the witness(es) out of the paths
669 foreach my $e ( $self->paths ) {
670 foreach my $sig ( @sigils ) {
671 $self->del_path( $e, $sig );
675 # Clear out the newly unused readings
676 foreach my $r ( $self->readings ) {
677 unless( $self->reading_witnesses( $r ) ) {
678 $self->del_reading( $r );
683 sub add_relationship {
685 my( $source, $target, $opts ) = $self->_stringify_args( @_ );
686 my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
687 foreach my $v ( @vectors ) {
688 next unless $self->get_relationship( $v )->colocated;
689 if( $self->reading( $v->[0] )->has_rank && $self->reading( $v->[1] )->has_rank
690 && $self->reading( $v->[0] )->rank ne $self->reading( $v->[1] )->rank ) {
691 $self->_graphcalc_done(0);
699 around qw/ get_relationship del_relationship / => sub {
703 if( @args == 1 && ref( $args[0] ) eq 'ARRAY' ) {
706 my @stringargs = $self->_stringify_args( @args );
707 $self->$orig( @stringargs );
710 =head2 reading_witnesses( $reading )
712 Return a list of sigils corresponding to the witnesses in which the reading appears.
716 sub reading_witnesses {
717 my( $self, $reading ) = @_;
718 # We need only check either the incoming or the outgoing edges; I have
719 # arbitrarily chosen "incoming". Thus, special-case the start node.
720 if( $reading eq $self->start ) {
721 return map { $_->sigil } grep { $_->is_collated } $self->tradition->witnesses;
724 foreach my $e ( $self->sequence->edges_to( $reading ) ) {
725 my $wits = $self->sequence->get_edge_attributes( @$e );
726 @all_witnesses{ keys %$wits } = 1;
728 my $acstr = $self->ac_label;
729 foreach my $acwit ( grep { $_ =~ s/^(.*)\Q$acstr\E$/$1/ } keys %all_witnesses ) {
730 delete $all_witnesses{$acwit.$acstr} if exists $all_witnesses{$acwit};
732 return keys %all_witnesses;
735 =head1 OUTPUT METHODS
737 =head2 as_svg( \%options )
739 Returns an SVG string that represents the graph, via as_dot and graphviz.
740 See as_dot for a list of options. Must have GraphViz (dot) installed to run.
745 my( $self, $opts ) = @_;
746 throw( "Need GraphViz installed to output SVG" )
747 unless File::Which::which( 'dot' );
748 my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
749 $self->calculate_ranks()
750 unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
751 my @cmd = qw/dot -Tsvg/;
753 my $dotfile = File::Temp->new();
755 # $dotfile->unlink_on_destroy(0);
756 binmode $dotfile, ':utf8';
757 print $dotfile $self->as_dot( $opts );
758 push( @cmd, $dotfile->filename );
759 run( \@cmd, ">", binary(), \$svg );
760 $svg = decode_utf8( $svg );
765 =head2 as_dot( \%options )
767 Returns a string that is the collation graph expressed in dot
768 (i.e. GraphViz) format. Options include:
783 my( $self, $opts ) = @_;
784 my $startrank = $opts->{'from'} if $opts;
785 my $endrank = $opts->{'to'} if $opts;
786 my $color_common = $opts->{'color_common'} if $opts;
787 my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
788 && $self->end->rank > 100;
789 $STRAIGHTENHACK = 1 if $opts->{'straight'}; # even for subgraphs or small graphs
791 # Check the arguments
793 return if $endrank && $startrank > $endrank;
794 return if $startrank > $self->end->rank;
796 if( defined $endrank ) {
797 return if $endrank < 0;
798 $endrank = undef if $endrank == $self->end->rank;
801 my $graph_name = $self->tradition->name;
802 $graph_name =~ s/[^\w\s]//g;
803 $graph_name = join( '_', split( /\s+/, $graph_name ) );
811 'fillcolor' => 'white',
816 'arrowhead' => 'open',
817 'color' => '#000000',
818 'fontcolor' => '#000000',
821 my $dot = sprintf( "digraph %s {\n", $graph_name );
822 $dot .= "\tgraph " . _dot_attr_string( \%graph_attrs ) . ";\n";
823 $dot .= "\tnode " . _dot_attr_string( \%node_attrs ) . ";\n";
825 # Output substitute start/end readings if necessary
827 $dot .= "\t\"__SUBSTART__\" [ label=\"...\",id=\"__START__\" ];\n";
830 $dot .= "\t\"__SUBEND__\" [ label=\"...\",id=\"__END__\" ];\n";
832 if( $STRAIGHTENHACK ) {
834 my $startlabel = $startrank ? '__SUBSTART__' : '__START__';
835 $dot .= "\tsubgraph { rank=same \"$startlabel\" \"#SILENT#\" }\n";
836 $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];"
838 my %used; # Keep track of the readings that actually appear in the graph
839 # Sort the readings by rank if we have ranks; this speeds layout.
840 my @all_readings = $self->end->has_rank
841 ? sort { $a->rank <=> $b->rank } $self->readings
843 # TODO Refrain from outputting lacuna nodes - just grey out the edges.
844 foreach my $reading ( @all_readings ) {
845 # Only output readings within our rank range.
846 next if $startrank && $reading->rank < $startrank;
847 next if $endrank && $reading->rank > $endrank;
848 $used{$reading->id} = 1;
849 # Need not output nodes without separate labels
850 next if $reading->id eq $reading->text;
852 my $label = $reading->text;
853 $label .= '-' if $reading->join_next;
854 $label = "-$label" if $reading->join_prior;
855 $label =~ s/\"/\\\"/g;
856 $rattrs->{'label'} = $label;
857 $rattrs->{'id'} = $reading->id;
858 $rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
859 $dot .= sprintf( "\t\"%s\" %s;\n", $reading->id, _dot_attr_string( $rattrs ) );
862 # Add the real edges. Need to weight one edge per rank jump, in a
864 # my $weighted = $self->_add_edge_weights;
865 my @edges = $self->paths;
866 my( %substart, %subend );
867 foreach my $edge ( @edges ) {
868 # Do we need to output this edge?
869 if( $used{$edge->[0]} && $used{$edge->[1]} ) {
870 my $label = $self->_path_display_label( $opts,
871 $self->path_witnesses( $edge ) );
872 my $variables = { %edge_attrs, 'label' => $label };
874 # Account for the rank gap if necessary
875 my $rank0 = $self->reading( $edge->[0] )->rank
876 if $self->reading( $edge->[0] )->has_rank;
877 my $rank1 = $self->reading( $edge->[1] )->rank
878 if $self->reading( $edge->[1] )->has_rank;
879 if( defined $rank0 && defined $rank1 && $rank1 - $rank0 > 1 ) {
880 $variables->{'minlen'} = $rank1 - $rank0;
883 # Add the calculated edge weights
884 # if( exists $weighted->{$edge->[0]}
885 # && $weighted->{$edge->[0]} eq $edge->[1] ) {
886 # # $variables->{'color'} = 'red';
887 # $variables->{'weight'} = 3.0;
890 # EXPERIMENTAL: make edge width reflect no. of witnesses
891 my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
892 $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
894 my $varopts = _dot_attr_string( $variables );
895 $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
896 $edge->[0], $edge->[1], $varopts );
897 } elsif( $used{$edge->[0]} ) {
898 $subend{$edge->[0]} = $edge->[1];
899 } elsif( $used{$edge->[1]} ) {
900 $substart{$edge->[1]} = $edge->[0];
904 # If we are asked to, add relationship links
905 if( exists $opts->{show_relations} ) {
906 my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
907 if( $filter eq 'transposition' ) {
908 $filter =~ qr/^transposition$/;
910 foreach my $redge ( $self->relationships ) {
911 if( $used{$redge->[0]} && $used{$redge->[1]} ) {
912 if( $filter ne 'all' ) {
913 my $rel = $self->get_relationship( $redge );
914 next unless $rel->type =~ /$filter/;
918 constraint => 'false',
919 label => uc( substr( $rel->type, 0, 4 ) ),
922 $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
923 $redge->[0], $redge->[1], _dot_attr_string( $variables ) );
929 # Add substitute start and end edges if necessary
930 foreach my $node ( keys %substart ) {
931 my $witstr = $self->_path_display_label( $opts,
932 $self->path_witnesses( $substart{$node}, $node ) );
933 my $variables = { %edge_attrs, 'label' => $witstr };
934 my $nrdg = $self->reading( $node );
935 if( $nrdg->has_rank && $nrdg->rank > $startrank ) {
936 # Substart is actually one lower than $startrank
937 $variables->{'minlen'} = $nrdg->rank - ( $startrank - 1 );
939 my $varopts = _dot_attr_string( $variables );
940 $dot .= "\t\"__SUBSTART__\" -> \"$node\" $varopts;\n";
942 foreach my $node ( keys %subend ) {
943 my $witstr = $self->_path_display_label( $opts,
944 $self->path_witnesses( $node, $subend{$node} ) );
945 my $variables = { %edge_attrs, 'label' => $witstr };
946 my $varopts = _dot_attr_string( $variables );
947 $dot .= "\t\"$node\" -> \"__SUBEND__\" $varopts;\n";
950 if( $STRAIGHTENHACK ) {
951 my $endlabel = $endrank ? '__SUBEND__' : '__END__';
952 $dot .= "\t\"$endlabel\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
959 sub _dot_attr_string {
962 foreach my $k ( sort keys %$hash ) {
964 push( @attrs, $k.'="'.$v.'"' );
966 return( '[ ' . join( ', ', @attrs ) . ' ]' );
969 sub _add_edge_weights {
971 # Walk the graph from START to END, choosing the successor node with
972 # the largest number of witness paths each time.
974 my $curr = $self->start->id;
975 my $ranked = $self->end->has_rank;
976 while( $curr ne $self->end->id ) {
977 my $rank = $ranked ? $self->reading( $curr )->rank : 0;
978 my @succ = sort { $self->path_witnesses( $curr, $a )
979 <=> $self->path_witnesses( $curr, $b ) }
980 $self->sequence->successors( $curr );
981 my $next = pop @succ;
982 my $nextrank = $ranked ? $self->reading( $next )->rank : 0;
983 # Try to avoid lacunae in the weighted path.
985 ( $self->reading( $next )->is_lacuna ||
986 $nextrank - $rank > 1 ) ){
989 $weighted->{$curr} = $next;
995 =head2 path_witnesses( $edge )
997 Returns the list of sigils whose witnesses are associated with the given edge.
998 The edge can be passed as either an array or an arrayref of ( $source, $target ).
1002 sub path_witnesses {
1003 my( $self, @edge ) = @_;
1004 # If edge is an arrayref, cope.
1005 if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
1006 my $e = shift @edge;
1009 my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
1013 # Helper function. Make a display label for the given witnesses, showing a.c.
1014 # witnesses only where the main witness is not also in the list.
1015 sub _path_display_label {
1019 map { $wits{$_} = 1 } @_;
1021 # If an a.c. wit is listed, remove it if the main wit is also listed.
1022 # Otherwise keep it for explicit listing.
1023 my $aclabel = $self->ac_label;
1025 foreach my $w ( sort keys %wits ) {
1026 if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
1027 if( exists $wits{$1} ) {
1030 push( @disp_ac, $w );
1035 if( $opts->{'explicit_wits'} ) {
1036 return join( ', ', sort keys %wits );
1038 # See if we are in a majority situation.
1039 my $maj = scalar( $self->tradition->witnesses ) * 0.6;
1040 $maj = $maj > 5 ? $maj : 5;
1041 if( scalar keys %wits > $maj ) {
1042 unshift( @disp_ac, 'majority' );
1043 return join( ', ', @disp_ac );
1045 return join( ', ', sort keys %wits );
1050 =head2 readings_at_rank( $rank )
1052 Returns a list of readings at a given rank, taken from the alignment table.
1056 sub readings_at_rank {
1057 my( $self, $rank ) = @_;
1058 my $table = $self->alignment_table;
1059 # Table rank is real rank - 1.
1060 my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
1062 foreach my $e ( @elements ) {
1063 next unless ref( $e ) eq 'HASH';
1064 next unless exists $e->{'t'};
1065 $readings{$e->{'t'}->id} = $e->{'t'};
1067 return values %readings;
1072 Returns a GraphML representation of the collation. The GraphML will contain
1073 two graphs. The first expresses the attributes of the readings and the witness
1074 paths that link them; the second expresses the relationships that link the
1075 readings. This is the native transfer format for a tradition.
1079 use Text::Tradition;
1085 my $datafile = 't/data/florilegium_tei_ps.xml';
1086 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1088 'file' => $datafile,
1091 ok( $tradition, "Got a tradition object" );
1092 is( scalar $tradition->witnesses, 13, "Found all witnesses" );
1093 ok( $tradition->collation, "Tradition has a collation" );
1095 my $c = $tradition->collation;
1096 is( scalar $c->readings, $READINGS, "Collation has all readings" );
1097 is( scalar $c->paths, $PATHS, "Collation has all paths" );
1098 is( scalar $c->relationships, 0, "Collation has all relationships" );
1100 # Add a few relationships
1101 $c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
1102 $c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
1103 $c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
1105 # Now write it to GraphML and parse it again.
1107 my $graphml = $c->as_graphml;
1108 my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
1109 is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
1110 is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
1111 is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
1113 # Now add a stemma, write to GraphML, and look at the output.
1115 skip "Analysis module not present", 3 unless $tradition->can( 'add_stemma' );
1116 my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
1117 is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
1118 is( $tradition->stemmata, 1, "Tradition now has the stemma" );
1119 $graphml = $c->as_graphml;
1120 like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
1127 ## TODO MOVE this to Tradition.pm and modularize it better
1129 my( $self, $options ) = @_;
1130 $self->calculate_ranks unless $self->_graphcalc_done;
1132 my $start = $options->{'from'}
1133 ? $self->reading( $options->{'from'} ) : $self->start;
1134 my $end = $options->{'to'}
1135 ? $self->reading( $options->{'to'} ) : $self->end;
1136 if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
1137 throw( 'Start node must be before end node' );
1139 # The readings need to be ranked for this to work.
1140 $start = $self->start unless $start->has_rank;
1141 $end = $self->end unless $end->has_rank;
1143 unless( $start eq $self->start ) {
1144 $rankoffset = $start->rank - 1;
1149 my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
1150 my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
1151 my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
1152 'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
1154 # Create the document and root node
1155 require XML::LibXML;
1156 my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
1157 my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
1158 $graphml->setDocumentElement( $root );
1159 $root->setNamespace( $xsi_ns, 'xsi', 0 );
1160 $root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
1162 # List of attribute types to save on our objects and their corresponding
1167 'Bool' => 'boolean',
1168 'ReadingID' => 'string',
1169 'RelationshipType' => 'string',
1170 'RelationshipScope' => 'string',
1173 # Add the data keys for the graph. Include an extra key 'version' for the
1174 # GraphML output version.
1175 my %graph_data_keys;
1177 my %graph_attributes = ( 'version' => 'string' );
1178 # Graph attributes include those of Tradition and those of Collation.
1180 # TODO Use meta introspection method from duplicate_reading to do this
1181 # instead of naming custom keys.
1182 my $tmeta = $self->tradition->meta;
1183 my $cmeta = $self->meta;
1184 map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
1185 map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
1186 foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
1187 next if $attr->name =~ /^_/;
1188 next unless $save_types{$attr->type_constraint->name};
1189 $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1191 # Extra custom keys for complex objects that should be saved in some form.
1192 # The subroutine should return a string, or undef/empty.
1193 if( $tmeta->has_method('stemmata') ) {
1194 $graph_attributes{'stemmata'} = sub {
1196 map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
1197 $self->tradition->stemmata;
1198 join( "\n", @stemstrs );
1202 if( $tmeta->has_method('user') ) {
1203 $graph_attributes{'user'} = sub {
1204 $self->tradition->user ? $self->tradition->user->id : undef
1208 foreach my $datum ( sort keys %graph_attributes ) {
1209 $graph_data_keys{$datum} = 'dg'.$gdi++;
1210 my $key = $root->addNewChild( $graphml_ns, 'key' );
1211 my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
1212 : $graph_attributes{$datum};
1213 $key->setAttribute( 'attr.name', $datum );
1214 $key->setAttribute( 'attr.type', $dtype );
1215 $key->setAttribute( 'for', 'graph' );
1216 $key->setAttribute( 'id', $graph_data_keys{$datum} );
1219 # Add the data keys for reading nodes
1220 my %reading_attributes;
1221 my $rmeta = Text::Tradition::Collation::Reading->meta;
1222 foreach my $attr( $rmeta->get_all_attributes ) {
1223 next if $attr->name =~ /^_/;
1224 next unless $save_types{$attr->type_constraint->name};
1225 $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1227 if( $self->start->does('Text::Tradition::Morphology' ) ) {
1228 # Extra custom key for the reading morphology
1229 $reading_attributes{'lexemes'} = 'string';
1234 foreach my $datum ( sort keys %reading_attributes ) {
1235 $node_data_keys{$datum} = 'dn'.$ndi++;
1236 my $key = $root->addNewChild( $graphml_ns, 'key' );
1237 $key->setAttribute( 'attr.name', $datum );
1238 $key->setAttribute( 'attr.type', $reading_attributes{$datum} );
1239 $key->setAttribute( 'for', 'node' );
1240 $key->setAttribute( 'id', $node_data_keys{$datum} );
1243 # Add the data keys for edges, that is, paths and relationships. Path
1244 # data does not come from a Moose class so is here manually.
1247 my %edge_attributes = (
1248 witness => 'string', # ID/label for a path
1249 extra => 'boolean', # Path key
1251 my @path_attributes = keys %edge_attributes; # track our manual additions
1252 my $pmeta = Text::Tradition::Collation::Relationship->meta;
1253 foreach my $attr( $pmeta->get_all_attributes ) {
1254 next if $attr->name =~ /^_/;
1255 next unless $save_types{$attr->type_constraint->name};
1256 $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
1258 foreach my $datum ( sort keys %edge_attributes ) {
1259 $edge_data_keys{$datum} = 'de'.$edi++;
1260 my $key = $root->addNewChild( $graphml_ns, 'key' );
1261 $key->setAttribute( 'attr.name', $datum );
1262 $key->setAttribute( 'attr.type', $edge_attributes{$datum} );
1263 $key->setAttribute( 'for', 'edge' );
1264 $key->setAttribute( 'id', $edge_data_keys{$datum} );
1267 # Add the collation graph itself. First, sanitize the name to a valid XML ID.
1268 my $xmlidname = $self->tradition->name;
1269 $xmlidname =~ s/(?!$xml10_namechar_rx)./_/g;
1270 if( $xmlidname !~ /^$xml10_namestartchar_rx/ ) {
1271 $xmlidname = '_'.$xmlidname;
1273 my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
1274 $sgraph->setAttribute( 'edgedefault', 'directed' );
1275 $sgraph->setAttribute( 'id', $xmlidname );
1276 $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
1277 $sgraph->setAttribute( 'parse.edges', 0 ); # fill in later
1278 $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
1279 $sgraph->setAttribute( 'parse.nodes', 0 ); # fill in later
1280 $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
1282 # Tradition/collation attribute data
1283 foreach my $datum ( keys %graph_attributes ) {
1285 if( $datum eq 'version' ) {
1287 } elsif( ref( $graph_attributes{$datum} ) ) {
1288 my $sub = $graph_attributes{$datum};
1290 } elsif( $gattr_from{$datum} eq 'Tradition' ) {
1291 $value = $self->tradition->$datum;
1293 $value = $self->$datum;
1295 _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
1300 # Add our readings to the graph
1301 foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
1302 next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
1303 ( $n->rank < $start->rank || $n->rank > $end->rank );
1304 $use_readings{$n->id} = 1;
1305 # Add to the main graph
1306 my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
1307 my $node_xmlid = 'n' . $node_ctr++;
1308 $node_hash{ $n->id } = $node_xmlid;
1309 $node_el->setAttribute( 'id', $node_xmlid );
1310 foreach my $d ( keys %reading_attributes ) {
1312 # Custom serialization
1313 if( $d eq 'lexemes' ) {
1314 # If nval is a true value, we have lexemes so we need to
1315 # serialize them. Otherwise set nval to undef so that the
1316 # key is excluded from this reading.
1317 $nval = $nval ? $n->_serialize_lexemes : undef;
1318 } elsif( $d eq 'normal_form' && $n->normal_form eq $n->text ) {
1321 if( $rankoffset && $d eq 'rank' && $n ne $self->start ) {
1322 # Adjust the ranks within the subgraph.
1323 $nval = $n eq $self->end ? $end->rank - $rankoffset + 1
1324 : $nval - $rankoffset;
1326 _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
1331 # Add the path edges to the sequence graph
1333 foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
1334 # We add an edge in the graphml for every witness in $e.
1335 next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
1336 my @edge_wits = sort $self->path_witnesses( $e );
1337 $e->[0] = $self->start->id unless $use_readings{$e->[0]};
1338 $e->[1] = $self->end->id unless $use_readings{$e->[1]};
1339 # Skip any path from start to end; that witness is not in the subgraph.
1340 next if ( $e->[0] eq $self->start->id && $e->[1] eq $self->end->id );
1341 foreach my $wit ( @edge_wits ) {
1342 my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
1343 $node_hash{ $e->[0] },
1344 $node_hash{ $e->[1] } );
1345 my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
1346 $edge_el->setAttribute( 'source', $from );
1347 $edge_el->setAttribute( 'target', $to );
1348 $edge_el->setAttribute( 'id', $id );
1350 # It's a witness path, so add the witness
1352 my $key = $edge_data_keys{'witness'};
1353 # Is this an ante-corr witness?
1354 my $aclabel = $self->ac_label;
1355 if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
1356 # Keep the base witness
1358 # ...and record that this is an 'extra' reading path
1359 _add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
1361 _add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
1365 # Report the actual number of nodes and edges that went in
1366 $sgraph->setAttribute( 'parse.edges', $edge_ctr );
1367 $sgraph->setAttribute( 'parse.nodes', $node_ctr );
1369 # Add the relationship graph to the XML
1370 map { delete $edge_data_keys{$_} } @path_attributes;
1371 $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
1372 $node_data_keys{'id'}, \%edge_data_keys );
1374 # Save and return the thing
1375 my $result = decode_utf8( $graphml->toString(1) );
1379 sub _add_graphml_data {
1380 my( $el, $key, $value ) = @_;
1381 return unless defined $value;
1382 my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
1383 $data_el->setAttribute( 'key', $key );
1384 $data_el->appendText( $value );
1389 Returns a CSV alignment table representation of the collation graph, one
1390 row per witness (or witness uncorrected.)
1394 Returns a tab-separated alignment table representation of the collation graph,
1395 one row per witness (or witness uncorrected.)
1399 use Text::Tradition;
1407 my $datafile = 't/data/florilegium_tei_ps.xml';
1408 my $tradition = Text::Tradition->new( 'input' => 'TEI',
1410 'file' => $datafile,
1413 my $c = $tradition->collation;
1414 # Export the thing to CSV
1415 my $csvstr = $c->as_csv();
1417 my $csv = Text::CSV->new({ sep_char => ',', binary => 1 });
1418 my @lines = split(/\n/, $csvstr );
1419 ok( $csv->parse( $lines[0] ), "Successfully parsed first line of CSV" );
1420 is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness columns" );
1421 my @q_ac = grep { $_ eq 'Q'.$c->ac_label } $csv->fields;
1422 ok( @q_ac, "Found a layered witness" );
1424 my $t2 = Text::Tradition->new( input => 'Tabular',
1428 is( scalar $t2->collation->readings, $READINGS, "Reparsed CSV collation has all readings" );
1429 is( scalar $t2->collation->paths, $PATHS, "Reparsed CSV collation has all paths" );
1431 # Now do it with TSV
1432 my $tsvstr = $c->as_tsv();
1433 my $t3 = Text::Tradition->new( input => 'Tabular',
1437 is( scalar $t3->collation->readings, $READINGS, "Reparsed TSV collation has all readings" );
1438 is( scalar $t3->collation->paths, $PATHS, "Reparsed TSV collation has all paths" );
1440 my $table = $c->alignment_table;
1441 my $noaccsv = $c->as_csv({ noac => 1 });
1442 my @noaclines = split(/\n/, $noaccsv );
1443 ok( $csv->parse( $noaclines[0] ), "Successfully parsed first line of no-ac CSV" );
1444 is( scalar( $csv->fields ), $WITS, "CSV has correct number of witness columns" );
1445 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
1447 my $safecsv = $c->as_csv({ safe_ac => 1});
1448 my @safelines = split(/\n/, $safecsv );
1449 ok( $csv->parse( $safelines[0] ), "Successfully parsed first line of safe CSV" );
1450 is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness columns" );
1451 @q_ac = grep { $_ eq 'Q__L' } $csv->fields;
1452 ok( @q_ac, "Found a sanitized layered witness" );
1453 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
1460 my( $self, $opts ) = @_;
1461 my $table = $self->alignment_table( $opts );
1462 my $csv_options = { binary => 1, quote_null => 0 };
1463 $csv_options->{'sep_char'} = $opts->{fieldsep};
1464 if( $opts->{fieldsep} eq "\t" ) {
1465 # If it is really tab separated, nothing is an escape char.
1466 $csv_options->{'quote_char'} = undef;
1467 $csv_options->{'escape_char'} = '';
1469 my $csv = Text::CSV->new( $csv_options );
1471 # Make the header row
1472 $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
1473 push( @result, $csv->string );
1474 # Make the rest of the rows
1475 foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
1476 my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
1477 my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
1478 $csv->combine( @row );
1479 push( @result, $csv->string );
1481 return join( "\n", @result );
1486 my $opts = shift || {};
1487 $opts->{fieldsep} = ',';
1488 return $self->_tabular( $opts );
1493 my $opts = shift || {};
1494 $opts->{fieldsep} = "\t";
1495 return $self->_tabular( $opts );
1498 =head2 alignment_table
1500 Return a reference to an alignment table, in a slightly enhanced CollateX
1501 format which looks like this:
1503 $table = { alignment => [ { witness => "SIGIL",
1504 tokens => [ { t => "TEXT" }, ... ] },
1505 { witness => "SIG2",
1506 tokens => [ { t => "TEXT" }, ... ] },
1508 length => TEXTLEN };
1512 sub alignment_table {
1513 my( $self, $opts ) = @_;
1514 if( $self->has_cached_table ) {
1515 return $self->cached_table
1516 unless $opts->{noac} || $opts->{safe_ac};
1519 # Make sure we can do this
1520 throw( "Need a linear graph in order to make an alignment table" )
1521 unless $self->linear;
1522 $self->calculate_ranks()
1523 unless $self->_graphcalc_done && $self->end->has_rank;
1525 my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
1526 my @all_pos = ( 1 .. $self->end->rank - 1 );
1527 foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
1528 # say STDERR "Making witness row(s) for " . $wit->sigil;
1529 my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
1530 my @row = _make_witness_row( \@wit_path, \@all_pos );
1531 my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
1532 $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
1533 push( @{$table->{'alignment'}}, $witobj );
1534 if( $wit->is_layered && !$opts->{noac} ) {
1535 my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
1536 $wit->sigil.$self->ac_label );
1537 my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
1538 my $witlabel = $opts->{safe_ac}
1539 ? $wit->sigil . '__L' : $wit->sigil.$self->ac_label;
1540 my $witacobj = { 'witness' => $witlabel,
1541 'tokens' => \@ac_row };
1542 $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
1543 push( @{$table->{'alignment'}}, $witacobj );
1546 unless( $opts->{noac} || $opts->{safe_ac} ) {
1547 $self->cached_table( $table );
1552 sub _make_witness_row {
1553 my( $path, $positions ) = @_;
1555 map { $char_hash{$_} = undef } @$positions;
1557 foreach my $rdg ( @$path ) {
1558 say STDERR "rank " . $rdg->rank if $debug;
1559 # say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
1560 $char_hash{$rdg->rank} = { 't' => $rdg };
1562 my @row = map { $char_hash{$_} } @$positions;
1563 # Fill in lacuna markers for undef spots in the row
1564 my $last_el = shift @row;
1565 my @filled_row = ( $last_el );
1566 foreach my $el ( @row ) {
1567 # If we are using node reference, make the lacuna node appear many times
1568 # in the table. If not, use the lacuna tag.
1569 if( $last_el && $last_el->{'t'}->is_lacuna && !defined $el ) {
1572 push( @filled_row, $el );
1579 =head1 NAVIGATION METHODS
1581 =head2 reading_sequence( $first, $last, $sigil, $backup )
1583 Returns the ordered list of readings, starting with $first and ending
1584 with $last, for the witness given in $sigil. If a $backup sigil is
1585 specified (e.g. when walking a layered witness), it will be used wherever
1586 no $sigil path exists. If there is a base text reading, that will be
1587 used wherever no path exists for $sigil or $backup.
1591 # TODO Think about returning some lazy-eval iterator.
1592 # TODO Get rid of backup; we should know from what witness is whether we need it.
1594 sub reading_sequence {
1595 my( $self, $start, $end, $witness ) = @_;
1597 $witness = $self->baselabel unless $witness;
1598 my @readings = ( $start );
1601 while( $n && $n->id ne $end->id ) {
1602 if( exists( $seen{$n->id} ) ) {
1603 throw( "Detected loop for $witness at " . $n->id );
1607 my $next = $self->next_reading( $n, $witness );
1609 throw( "Did not find any path for $witness from reading " . $n->id );
1611 push( @readings, $next );
1614 # Check that the last reading is our end reading.
1615 my $last = $readings[$#readings];
1616 throw( "Last reading found from " . $start->text .
1617 " for witness $witness is not the end!" ) # TODO do we get this far?
1618 unless $last->id eq $end->id;
1623 =head2 next_reading( $reading, $sigil );
1625 Returns the reading that follows the given reading along the given witness
1631 # Return the successor via the corresponding path.
1633 my $answer = $self->_find_linked_reading( 'next', @_ );
1634 return undef unless $answer;
1635 return $self->reading( $answer );
1638 =head2 prior_reading( $reading, $sigil )
1640 Returns the reading that precedes the given reading along the given witness
1646 # Return the predecessor via the corresponding path.
1648 my $answer = $self->_find_linked_reading( 'prior', @_ );
1649 return $self->reading( $answer );
1652 sub _find_linked_reading {
1653 my( $self, $direction, $node, $path ) = @_;
1655 # Get a backup if we are dealing with a layered witness
1657 my $aclabel = $self->ac_label;
1658 if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
1662 my @linked_paths = $direction eq 'next'
1663 ? $self->sequence->edges_from( $node )
1664 : $self->sequence->edges_to( $node );
1665 return undef unless scalar( @linked_paths );
1667 # We have to find the linked path that contains all of the
1668 # witnesses supplied in $path.
1669 my( @path_wits, @alt_path_wits );
1670 @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
1671 @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
1674 foreach my $le ( @linked_paths ) {
1675 if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
1678 my @le_wits = sort $self->path_witnesses( $le );
1679 if( _is_within( \@path_wits, \@le_wits ) ) {
1680 # This is the right path.
1681 return $direction eq 'next' ? $le->[1] : $le->[0];
1682 } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
1686 # Got this far? Return the alternate path if it exists.
1687 return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
1690 # Got this far? Return the base path if it exists.
1691 return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
1694 # Got this far? We have no appropriate path.
1695 warn "Could not find $direction node from " . $node->id
1696 . " along path $path";
1702 my( $set1, $set2 ) = @_;
1703 my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
1704 foreach my $el ( @$set1 ) {
1705 $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
1710 # Return the string that joins together a list of witnesses for
1711 # display on a single path.
1712 sub _witnesses_of_label {
1713 my( $self, $label ) = @_;
1714 my $regex = $self->wit_list_separator;
1715 my @answer = split( /\Q$regex\E/, $label );
1719 =head2 common_readings
1721 Returns the list of common readings in the graph (i.e. those readings that are
1722 shared by all non-lacunose witnesses.)
1726 sub common_readings {
1728 my @common = grep { $_->is_common } $self->readings;
1732 =head2 path_text( $sigil, [, $start, $end ] )
1734 Returns the text of a witness (plus its backup, if we are using a layer)
1735 as stored in the collation. The text is returned as a string, where the
1736 individual readings are joined with spaces and the meta-readings (e.g.
1737 lacunae) are omitted. Optional specification of $start and $end allows
1738 the generation of a subset of the witness text.
1743 my( $self, $wit, $start, $end ) = @_;
1744 $start = $self->start unless $start;
1745 $end = $self->end unless $end;
1746 my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
1749 foreach my $r ( @path ) {
1750 unless ( $r->join_prior || !$last || $last->join_next ) {
1753 $pathtext .= $r->text;
1759 =head1 INITIALIZATION METHODS
1761 These are mostly for use by parsers.
1763 =head2 make_witness_path( $witness )
1765 Link the array of readings contained in $witness->path (and in
1766 $witness->uncorrected_path if it exists) into collation paths.
1767 Clear out the arrays when finished.
1769 =head2 make_witness_paths
1771 Call make_witness_path for all witnesses in the tradition.
1775 # For use when a collation is constructed from a base text and an apparatus.
1776 # We have the sequences of readings and just need to add path edges.
1777 # When we are done, clear out the witness path attributes, as they are no
1779 # TODO Find a way to replace the witness path attributes with encapsulated functions?
1781 sub make_witness_paths {
1783 foreach my $wit ( $self->tradition->witnesses ) {
1784 # say STDERR "Making path for " . $wit->sigil;
1785 $self->make_witness_path( $wit );
1789 sub make_witness_path {
1790 my( $self, $wit ) = @_;
1791 my @chain = @{$wit->path};
1792 my $sig = $wit->sigil;
1793 # Add start and end if necessary
1794 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1795 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1796 foreach my $idx ( 0 .. $#chain-1 ) {
1797 $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
1799 if( $wit->is_layered ) {
1800 @chain = @{$wit->uncorrected_path};
1801 unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
1802 push( @chain, $self->end ) unless $chain[-1] eq $self->end;
1803 foreach my $idx( 0 .. $#chain-1 ) {
1804 my $source = $chain[$idx];
1805 my $target = $chain[$idx+1];
1806 $self->add_path( $source, $target, $sig.$self->ac_label )
1807 unless $self->has_path( $source, $target, $sig );
1811 $wit->clear_uncorrected_path;
1814 =head2 calculate_ranks
1816 Calculate the reading ranks (that is, their aligned positions relative
1817 to each other) for the graph. This can only be called on linear collations.
1821 use Text::Tradition;
1823 my $cxfile = 't/data/Collatex-16.xml';
1824 my $t = Text::Tradition->new(
1826 'input' => 'CollateX',
1829 my $c = $t->collation;
1832 my $table = $c->alignment_table;
1833 ok( $c->has_cached_table, "Alignment table was cached" );
1834 is( $c->alignment_table, $table, "Cached table returned upon second call" );
1835 $c->calculate_ranks;
1836 is( $c->alignment_table, $table, "Cached table retained with no rank change" );
1837 $c->add_relationship( 'n13', 'n23', { type => 'repetition' } );
1838 is( $c->alignment_table, $table, "Alignment table unchanged after non-colo relationship add" );
1839 $c->add_relationship( 'n24', 'n23', { type => 'spelling' } );
1840 isnt( $c->alignment_table, $table, "Alignment table changed after colo relationship add" );
1846 sub calculate_ranks {
1848 # Save the existing ranks, in case we need to invalidate the cached SVG.
1850 map { $existing_ranks{$_} = $_->rank } $self->readings;
1852 # Do the rankings based on the relationship equivalence graph, starting
1853 # with the start node.
1854 my ( $node_ranks, $rank_nodes ) = $self->relations->equivalence_ranks();
1856 # Transfer our rankings from the topological graph to the real one.
1857 foreach my $r ( $self->readings ) {
1858 if( defined $node_ranks->{$self->equivalence( $r->id )} ) {
1859 $r->rank( $node_ranks->{$self->equivalence( $r->id )} );
1861 # Die. Find the last rank we calculated.
1862 my @all_defined = sort { ( $node_ranks->{$self->equivalence( $a->id )}||-1 )
1863 <=> ( $node_ranks->{$self->equivalence( $b->id )}||-1 ) }
1865 my $last = pop @all_defined;
1866 throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
1869 # Do we need to invalidate the cached data?
1870 if( $self->has_cached_table ) {
1871 foreach my $r ( $self->readings ) {
1872 next if defined( $existing_ranks{$r} )
1873 && $existing_ranks{$r} == $r->rank;
1874 # Something has changed, so clear the cache
1875 $self->_clear_cache;
1876 # ...and recalculate the common readings.
1877 $self->calculate_common_readings();
1881 # The graph calculation information is now up to date.
1882 $self->_graphcalc_done(1);
1887 $self->wipe_table if $self->has_cached_table;
1891 =head2 flatten_ranks
1893 A convenience method for parsing collation data. Searches the graph for readings
1894 with the same text at the same rank, and merges any that are found.
1899 my ( $self, %args ) = shift;
1900 my %unique_rank_rdg;
1902 foreach my $p ( $self->identical_readings( %args ) ) {
1903 # say STDERR "Combining readings at same rank: @$p";
1905 $self->merge_readings( @$p );
1906 # TODO see if this now makes a common point.
1908 # If we merged readings, the ranks are still fine but the alignment
1909 # table is wrong. Wipe it.
1910 $self->wipe_table() if $changed;
1913 =head2 identical_readings
1914 =head2 identical_readings( start => $startnode, end => $endnode )
1915 =head2 identical_readings( startrank => $startrank, endrank => $endrank )
1917 Goes through the graph identifying all pairs of readings that appear to be
1918 identical, and therefore able to be merged into a single reading. Returns the
1919 relevant identical pairs. Can be restricted to run over only a part of the
1920 graph, specified either by node or by rank.
1924 sub identical_readings {
1925 my ( $self, %args ) = @_;
1926 # Find where we should start and end.
1927 my $startrank = $args{startrank} || 0;
1928 if( $args{start} ) {
1929 throw( "Starting reading has no rank" ) unless $self->reading( $args{start} )
1930 && $self->reading( $args{start} )->has_rank;
1931 $startrank = $self->reading( $args{start} )->rank;
1933 my $endrank = $args{endrank} || $self->end->rank;
1935 throw( "Ending reading has no rank" ) unless $self->reading( $args{end} )
1936 && $self->reading( $args{end} )->has_rank;
1937 $endrank = $self->reading( $args{end} )->rank;
1940 # Make sure the ranks are correct.
1941 unless( $self->_graphcalc_done ) {
1942 $self->calculate_ranks;
1944 # Go through the readings looking for duplicates.
1945 my %unique_rank_rdg;
1947 foreach my $rdg ( $self->readings ) {
1948 next unless $rdg->has_rank;
1949 my $rk = $rdg->rank;
1950 next if $rk > $endrank || $rk < $startrank;
1951 my $key = $rk . "||" . $rdg->text;
1952 if( exists $unique_rank_rdg{$key} ) {
1953 # Make sure they don't have different grammatical forms
1954 my $ur = $unique_rank_rdg{$key};
1955 if( $rdg->is_identical( $ur ) ) {
1956 push( @pairs, [ $ur, $rdg ] );
1959 $unique_rank_rdg{$key} = $rdg;
1967 =head2 calculate_common_readings
1969 Goes through the graph identifying the readings that appear in every witness
1970 (apart from those with lacunae at that spot.) Marks them as common and returns
1975 use Text::Tradition;
1977 my $cxfile = 't/data/Collatex-16.xml';
1978 my $t = Text::Tradition->new(
1980 'input' => 'CollateX',
1983 my $c = $t->collation;
1985 my @common = $c->calculate_common_readings();
1986 is( scalar @common, 8, "Found correct number of common readings" );
1987 my @marked = sort $c->common_readings();
1988 is( scalar @common, 8, "All common readings got marked as such" );
1989 my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
1990 is_deeply( \@marked, \@expected, "Found correct list of common readings" );
1996 sub calculate_common_readings {
1999 map { $_->is_common( 0 ) } $self->readings;
2000 # Implicitly calls calculate_ranks
2001 my $table = $self->alignment_table;
2002 foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
2003 my @row = map { $_->{'tokens'}->[$idx]
2004 ? $_->{'tokens'}->[$idx]->{'t'} : '' }
2005 @{$table->{'alignment'}};
2007 foreach my $r ( @row ) {
2009 $hash{$r->id} = $r unless $r->is_meta;
2011 $hash{'UNDEF'} = $r;
2014 if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
2015 my( $r ) = values %hash;
2017 push( @common, $r );
2023 =head2 text_from_paths
2025 Calculate the text array for all witnesses from the path, for later consistency
2026 checking. Only to be used if there is no non-graph-based way to know the
2031 sub text_from_paths {
2033 foreach my $wit ( $self->tradition->witnesses ) {
2034 my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
2036 foreach my $r ( @readings ) {
2037 next if $r->is_meta;
2038 push( @text, $r->text );
2040 $wit->text( \@text );
2041 if( $wit->is_layered ) {
2042 my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
2043 $wit->sigil.$self->ac_label );
2045 foreach my $r ( @ucrdgs ) {
2046 next if $r->is_meta;
2047 push( @uctext, $r->text );
2049 $wit->layertext( \@uctext );
2054 =head1 UTILITY FUNCTIONS
2056 =head2 common_predecessor( $reading_a, $reading_b )
2058 Find the last reading that occurs in sequence before both the given readings.
2059 At the very least this should be $self->start.
2061 =head2 common_successor( $reading_a, $reading_b )
2063 Find the first reading that occurs in sequence after both the given readings.
2064 At the very least this should be $self->end.
2068 use Text::Tradition;
2070 my $cxfile = 't/data/Collatex-16.xml';
2071 my $t = Text::Tradition->new(
2073 'input' => 'CollateX',
2076 my $c = $t->collation;
2078 is( $c->common_predecessor( 'n24', 'n23' )->id,
2079 'n20', "Found correct common predecessor" );
2080 is( $c->common_successor( 'n24', 'n23' )->id,
2081 '__END__', "Found correct common successor" );
2083 is( $c->common_predecessor( 'n19', 'n17' )->id,
2084 'n16', "Found correct common predecessor for readings on same path" );
2085 is( $c->common_successor( 'n21', 'n10' )->id,
2086 '__END__', "Found correct common successor for readings on same path" );
2092 ## Return the closest reading that is a predecessor of both the given readings.
2093 sub common_predecessor {
2095 my( $r1, $r2 ) = $self->_objectify_args( @_ );
2096 return $self->_common_in_path( $r1, $r2, 'predecessors' );
2099 sub common_successor {
2101 my( $r1, $r2 ) = $self->_objectify_args( @_ );
2102 return $self->_common_in_path( $r1, $r2, 'successors' );
2106 # TODO think about how to do this without ranks...
2107 sub _common_in_path {
2108 my( $self, $r1, $r2, $dir ) = @_;
2109 my $iter = $self->end->rank;
2111 my @last_r1 = ( $r1 );
2112 my @last_r2 = ( $r2 );
2113 # my %all_seen = ( $r1 => 'r1', $r2 => 'r2' );
2115 # say STDERR "Finding common $dir for $r1, $r2";
2116 while( !@candidates ) {
2117 last unless $iter--; # Avoid looping infinitely
2118 # Iterate separately down the graph from r1 and r2
2119 my( @new_lc1, @new_lc2 );
2120 foreach my $lc ( @last_r1 ) {
2121 foreach my $p ( $lc->$dir ) {
2122 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r1' ) {
2123 # say STDERR "Path candidate $p from $lc";
2124 push( @candidates, $p );
2125 } elsif( !$all_seen{$p->id} ) {
2126 $all_seen{$p->id} = 'r1';
2127 push( @new_lc1, $p );
2131 foreach my $lc ( @last_r2 ) {
2132 foreach my $p ( $lc->$dir ) {
2133 if( $all_seen{$p->id} && $all_seen{$p->id} ne 'r2' ) {
2134 # say STDERR "Path candidate $p from $lc";
2135 push( @candidates, $p );
2136 } elsif( !$all_seen{$p->id} ) {
2137 $all_seen{$p->id} = 'r2';
2138 push( @new_lc2, $p );
2142 @last_r1 = @new_lc1;
2143 @last_r2 = @new_lc2;
2145 my @answer = sort { $a->rank <=> $b->rank } @candidates;
2146 return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
2150 Text::Tradition::Error->throw(
2151 'ident' => 'Collation error',
2157 __PACKAGE__->meta->make_immutable;
2163 =item * Rework XML serialization in a more modular way
2169 This package is free software and is provided "as is" without express
2170 or implied warranty. You can redistribute it and/or modify it under
2171 the same terms as Perl itself.
2175 Tara L Andrews E<lt>aurum@cpan.orgE<gt>