From: Tara L Andrews <tla@mit.edu>
Date: Tue, 25 Sep 2012 02:41:32 +0000 (+0200)
Subject: first ugly stab at relationship links in SVG; add identifier to alignment
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bed6ce83ab5c4625594460292c6b05641f847210;p=scpubgit%2Fstemmatology.git

first ugly stab at relationship links in SVG; add identifier to alignment
---

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index 10426aa..720d7fe 100644
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -552,7 +552,7 @@ sub reading_witnesses {
 	# We need only check either the incoming or the outgoing edges; I have
 	# arbitrarily chosen "incoming".  Thus, special-case the start node.
 	if( $reading eq $self->start ) {
-		return map { $_->sigil } $self->tradition->witnesses;
+		return map { $_->sigil } grep { $_->is_collated } $self->tradition->witnesses;
 	}
 	my %all_witnesses;
 	foreach my $e ( $self->sequence->edges_to( $reading ) ) {
@@ -733,6 +733,32 @@ sub as_dot {
         	$substart{$edge->[1]} = $edge->[0];
         }
     }
+    
+    # If we are asked to, add relationship links
+    if( exists $opts->{show_relations} ) {
+    	my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
+    	if( $filter eq 'transposition' ) {
+    		$filter =~ qr/^transposition$/;
+    	}
+    	foreach my $redge ( $self->relationships ) {
+    		if( $used{$redge->[0]} && $used{$redge->[1]} ) {
+    			if( $filter ne 'all' ) {
+    				my $rel = $self->get_relationship( $redge );
+    				next unless $rel->type =~ /$filter/;
+					my $variables = { 
+						arrowhead => 'none',
+						color => '#FFA14F',
+						constraint => 'false',
+						label => uc( substr( $rel->type, 0, 4 ) ), 
+						penwidth => '3',
+					};
+					$dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
+						$redge->[0], $redge->[1], _dot_attr_string( $variables ) );
+				}
+    		}
+    	}
+    }
+    
     # Add substitute start and end edges if necessary
     foreach my $node ( keys %substart ) {
     	my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
@@ -1243,14 +1269,17 @@ sub alignment_table {
         # say STDERR "Making witness row(s) for " . $wit->sigil;
         my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
         my @row = _make_witness_row( \@wit_path, \@all_pos );
-        push( @{$table->{'alignment'}}, 
-        	{ 'witness' => $wit->sigil, 'tokens' => \@row } );
+        my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
+        $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
+        push( @{$table->{'alignment'}}, $witobj );
         if( $wit->is_layered ) {
         	my @wit_ac_path = $self->reading_sequence( $self->start, $self->end, 
         		$wit->sigil.$self->ac_label );
             my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
-			push( @{$table->{'alignment'}},
-				{ 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
+            my $witacobj = { 'witness' => $wit->sigil.$self->ac_label, 
+            	'tokens' => \@ac_row };
+            $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
+			push( @{$table->{'alignment'}}, $witacobj );
         }           
     }
     $self->cached_table( $table );