enable graphml export of partial traditions

[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation.pm

diff --git a/lib/Text/Tradition/Collation.pm b/lib/Text/Tradition/Collation.pm
index 4f7f571..7926844 100644 (file)
--- a/lib/Text/Tradition/Collation.pm
+++ b/lib/Text/Tradition/Collation.pm
@@ -5,7 +5,7 @@ use File::Temp;
 use File::Which;
 use Graph;
 use IPC::Run qw( run binary );
-use Text::CSV_XS;
+use Text::CSV;
 use Text::Tradition::Collation::Reading;
 use Text::Tradition::Collation::RelationshipStore;
 use Text::Tradition::Error;
@@ -37,6 +37,7 @@ has 'relations' => (
 has 'tradition' => (
     is => 'ro',
     isa => 'Text::Tradition',
+    writer => '_set_tradition',
     weak_ref => 1,
     );
 
@@ -550,7 +551,7 @@ sub as_svg {
     throw( "Need GraphViz installed to output SVG" )
        unless File::Which::which( 'dot' );
     my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
-    $self->calculate_ranks() unless $self->_graphcalc_done;
+    $self->calculate_ranks() unless( $self->_graphcalc_done || $opts->{'nocalc'} );
     if( !$self->has_cached_svg || $opts->{'recalc'}    || $want_subgraph ) {        
                my @cmd = qw/dot -Tsvg/;
                my( $svg, $err );
@@ -881,9 +882,21 @@ is( scalar $st->collation->relationships, 3, "Reparsed collation has new relatio
 =cut
 
 sub as_graphml {
-    my( $self ) = @_;
+    my( $self, $options ) = @_;
        $self->calculate_ranks unless $self->_graphcalc_done;
        
+       my $start = $options->{'from'} 
+               ? $self->reading( $options->{'from'} ) : $self->start;
+       my $end = $options->{'to'} 
+               ? $self->reading( $options->{'to'} ) : $self->end;
+       if( $start->has_rank && $end->has_rank && $end->rank < $start->rank ) {
+               throw( 'Start node must be before end node' );
+       }
+       # The readings need to be ranked for this to work.
+       $start = $self->start unless $start->has_rank;
+       $end = $self->end unless $end->has_rank;
+       my %use_readings;
+       
     # Some namespaces
     my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
     my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
@@ -1011,6 +1024,9 @@ sub as_graphml {
     my %node_hash;
     # Add our readings to the graph
     foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
+       next if $n->has_rank && $n ne $self->start && $n ne $self->end &&
+               ( $n->rank < $start->rank || $n->rank > $end->rank );
+       $use_readings{$n->id} = 1;
        # Add to the main graph
         my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
         my $node_xmlid = 'n' . $node_ctr++;
@@ -1027,7 +1043,11 @@ sub as_graphml {
     my $edge_ctr = 0;
     foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
        # We add an edge in the graphml for every witness in $e.
-       foreach my $wit ( sort $self->path_witnesses( $e ) ) {
+       next unless( $use_readings{$e->[0]} || $use_readings{$e->[1]} );
+       my @edge_wits = sort $self->path_witnesses( $e );
+       $e->[0] = $self->start unless $use_readings{$e->[0]};
+       $e->[1] = $self->end unless $use_readings{$e->[1]};
+       foreach my $wit ( @edge_wits ) {
                        my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
                                                                                $node_hash{ $e->[0] },
                                                                                $node_hash{ $e->[1] } );
@@ -1079,7 +1099,7 @@ row per witness (or witness uncorrected.)
 sub as_csv {
     my( $self ) = @_;
     my $table = $self->alignment_table;
-    my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );    
+    my $csv = Text::CSV->new( { binary => 1, quote_null => 0 } );    
     my @result;
     # Make the header row
     $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
@@ -1390,7 +1410,6 @@ sub make_witness_path {
     # Add start and end if necessary
     unshift( @chain, $self->start ) unless $chain[0] eq $self->start;
     push( @chain, $self->end ) unless $chain[-1] eq $self->end;
-    $DB::single = 1;
     foreach my $idx ( 0 .. $#chain-1 ) {
         $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
     }
@@ -1493,8 +1512,8 @@ sub calculate_ranks {
             $r->rank( $node_ranks->{$rel_containers{$r->id}} );
         } else {
                # Die. Find the last rank we calculated.
-               my @all_defined = sort { $node_ranks->{$rel_containers{$a->id}}
-                                <=> $node_ranks->{$rel_containers{$b->id}} }
+               my @all_defined = sort { ( $node_ranks->{$rel_containers{$a->id}}||-1 )
+                                <=> ( $node_ranks->{$rel_containers{$b->id}}||-1 ) }
                        $self->readings;
                my $last = pop @all_defined;
             throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );