From: Tara L Andrews <tla@mit.edu>
Date: Mon, 20 Jan 2014 22:41:29 +0000 (+0100)
Subject: allow color specification for relationship links in SVG. Needed for tla/stemmaweb #34
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e54e11b3503582ced2ce1511b8f3bf06cd7df03;p=scpubgit%2Fstemmatology.git

allow color specification for relationship links in SVG. Needed for tla/stemmaweb #34
---

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index ce46556..904d39d 100644
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -1033,21 +1033,30 @@ sub as_dot {
     	if( $filter eq 'transposition' ) {
     		$filter =~ qr/^transposition$/;
     	}
+    	my %typecolors;
+    	my @types = sort( map { $_->name } $self->relations->types );
+    	if( exists $opts->{graphcolors} ) {
+    		foreach my $tdx ( 0 .. $#types ) {
+    			$typecolors{$types[$tdx]} = $opts->{graphcolors}->[$tdx];
+    		}
+    	} else {
+    		map { $typecolors{$_} = '#FFA14F' } @types;
+    	}
     	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 ) );
+				my $rel = $self->get_relationship( $redge );
+				next unless $filter eq 'all' || $rel->type =~ /$filter/;
+				my $variables = { 
+					arrowhead => 'none',
+					color => $typecolors{$rel->type},
+					constraint => 'false',
+					penwidth => '3',
+				};
+				unless( exists $opts->{graphcolors} ) {
+					$variables->{label} = uc( substr( $rel->type, 0, 4 ) ), 
 				}
+				$dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
+					$redge->[0], $redge->[1], _dot_attr_string( $variables ) );
     		}
     	}
     }