From: Tara L Andrews <tla@mit.edu>
Date: Mon, 9 Jun 2014 20:34:39 +0000 (+0200)
Subject: allow quick and dirty reading merge by relationship type in tab output
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de20588d9f4bf68928026636a5971e8ed9d0f6f2;p=scpubgit%2Fstemmatology.git

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
--- 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
--- 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" );
 }