allow quick and dirty reading merge by relationship type in tab output

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index 88fd3c8..0e8162e 100644 (file)
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -1641,6 +1641,18 @@ is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness c
 ok( @q_ac, "Found a sanitized layered witness" );
 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
 
+# Test relationship collapse
+$c->add_relationship( $c->readings_at_rank( 37 ), { type => 'spelling' } );
+$c->add_relationship( $c->readings_at_rank( 60 ), { type => 'spelling' } );
+
+my $mergedtsv = $c->as_tsv({mergetypes => [ 'spelling', 'orthographic' ] });
+my $t4 = Text::Tradition->new( input => 'Tabular',
+                                                          name => 'test4',
+                                                          string => $mergedtsv,
+                                                          sep_char => "\t" );
+is( scalar $t4->collation->readings, $READINGS - 2, "Reparsed TSV merge collation has fewer readings" );
+is( scalar $t4->collation->paths, $PATHS - 4, "Reparsed TSV merge collation has fewer paths" );
+
 =end testing
 
 =cut
@@ -1664,6 +1676,29 @@ sub _tabular {
     foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
        my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
        my @row = map { $_ ? $_->{'t'}->text : $_ } @rowobjs;
+       # Quick and dirty collapse of requested relationship types
+       if( ref( $opts->{mergetypes} ) eq 'ARRAY' ) {
+               # Now substitute the reading in the relevant index of @row
+               # for its merge-related reading
+               my %substitutes;
+               while( @rowobjs ) {
+                       my $thisr = shift @rowobjs;
+                       next unless $thisr;
+                               next if exists $substitutes{$thisr->{t}->text};
+                               # Make sure we don't have A <-> B substitutions.
+                               $substitutes{$thisr->{t}->text} = $thisr->{t}->text;
+                       foreach my $thatr ( @rowobjs ) {
+                               next unless $thatr;
+                               next if exists $substitutes{$thatr->{t}->text};
+                               my $ttrel = $self->get_relationship( $thisr->{t}, $thatr->{t} );
+                               next unless $ttrel;
+                               next unless grep { $ttrel->type eq $_ } @{$opts->{mergetypes}};
+                               # If we have got this far then we need to merge them.
+                               $substitutes{$thatr->{t}->text} = $thisr->{t}->text;
+                       }
+               }
+               @row = map { $_ && exists $substitutes{$_} ? $substitutes{$_} : $_ } @row;
+       }
         $csv->combine( @row );
         push( @result, $csv->string );
     }

diff --git a/base/t/text_tradition_collation.t b/base/t/text_tradition_collation.t
index bee39e0..f2cee5f 100644 (file)
--- a/base/t/text_tradition_collation.t
+++ b/base/t/text_tradition_collation.t
@@ -295,6 +295,18 @@ is( scalar( $csv->fields ), $WITS + $WITAC, "CSV has correct number of witness c
 @q_ac = grep { $_ eq 'Q__L' } $csv->fields;
 ok( @q_ac, "Found a sanitized layered witness" );
 is( $c->alignment_table, $table, "Request for CSV did not alter the alignment table" );
+
+# Test relationship collapse
+$c->add_relationship( $c->readings_at_rank( 37 ), { type => 'spelling' } );
+$c->add_relationship( $c->readings_at_rank( 60 ), { type => 'spelling' } );
+
+my $mergedtsv = $c->as_tsv({mergetypes => [ 'spelling', 'orthographic' ] });
+my $t4 = Text::Tradition->new( input => 'Tabular',
+                                                          name => 'test4',
+                                                          string => $mergedtsv,
+                                                          sep_char => "\t" );
+is( scalar $t4->collation->readings, $READINGS - 2, "Reparsed TSV merge collation has fewer readings" );
+is( scalar $t4->collation->paths, $PATHS - 4, "Reparsed TSV merge collation has fewer paths" );
 }