just export variants; Analysis really needs a refactor now.

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

diff --git a/lib/Text/Tradition/Stemma.pm b/lib/Text/Tradition/Stemma.pm
index a90d863..e241d56 100644 (file)
--- a/lib/Text/Tradition/Stemma.pm
+++ b/lib/Text/Tradition/Stemma.pm
@@ -1,11 +1,13 @@
 package Text::Tradition::Stemma;
 
 use Bio::Phylo::IO;
+use Encode qw( decode_utf8 );
 use File::chdir;
 use File::Temp;
 use Graph;
+use Graph::Convert;
 use Graph::Reader::Dot;
-use IPC::Run qw/ run /;
+use IPC::Run qw/ run binary /;
 use Moose;
 use Text::Balanced qw/ extract_bracketed /;
 
@@ -15,62 +17,80 @@ has collation => (
     required => 1,
     );  
 
-has character_matrix => (
-    is => 'ro',
-    isa => 'ArrayRef[ArrayRef[Str]]',
-    writer => '_save_character_matrix',
-    predicate => 'has_character_matrix',
-    );
-    
 has graph => (
     is => 'rw',
     isa => 'Graph',
     predicate => 'has_graph',
     );
     
-has apsp => (
-    is => 'rw',
-    isa => 'Graph',
-    );
-    
 has distance_trees => (
     is => 'ro',
     isa => 'ArrayRef[Graph]',
     writer => '_save_distance_trees',
     predicate => 'has_distance_trees',
     );
-        
+    
 sub BUILD {
     my( $self, $args ) = @_;
     # If we have been handed a dotfile, initialize it into a graph.
     if( exists $args->{'dot'} ) {
+        # Open the file, assume UTF-8
+        open( my $dot, $args->{'dot'} ) or warn "Failed to read dot file";
+        # TODO don't bother if we haven't opened
+        binmode $dot, ":utf8";
         my $reader = Graph::Reader::Dot->new();
-        my $graph = $reader->read_graph( $args->{'dot'} );
+        my $graph = $reader->read_graph( $dot );
         $graph 
             ? $self->graph( $graph ) 
             : warn "Failed to parse dot file " . $args->{'dot'};
     }
-    
-    # If we have a graph, calculate all the shortest paths between nodes,
-    # disregarding direction.
-    if( $self->has_graph ) {
-        my $undirected;
-        if( $self->graph->is_directed ) {
-            # Make an undirected version.
-            $undirected = Graph->new( 'undirected' => 1 );
-            foreach my $v ( $self->graph->vertices ) {
-                $undirected->add_vertex( $v );
-            }
-            foreach my $e ( $self->graph->edges ) {
-                $undirected->add_edge( @$e );
-            }
+}
+
+# Render the stemma as SVG.
+sub as_svg {
+    my( $self, $opts ) = @_;
+    # TODO add options for display, someday
+    my $dgraph = Graph::Convert->as_graph_easy( $self->graph );
+    # Set some class display attributes for 'hypothetical' and 'extant' nodes
+    $dgraph->set_attribute( 'flow', 'south' );
+    foreach my $n ( $dgraph->nodes ) {
+        if( $n->attribute( 'class' ) eq 'hypothetical' ) {
+            $n->set_attribute( 'shape', 'point' );
+            $n->set_attribute( 'pointshape', 'diamond' );
         } else {
-            $undirected = $self->graph;
+            $n->set_attribute( 'shape', 'ellipse' );
         }
-        $self->apsp( $undirected->APSP_Floyd_Warshall() );
     }
+    
+    # Render to svg via graphviz
+    my @lines = split( /\n/, $dgraph->as_graphviz() );
+    # Add the size attribute
+    if( $opts->{'size'} ) {
+        my $sizeline = "  graph [ size=\"" . $opts->{'size'} . "\" ]";
+        splice( @lines, 1, 0, $sizeline );
+    }
+    my @cmd = qw/dot -Tsvg/;
+    my( $svg, $err );
+    my $dotfile = File::Temp->new();
+    ## TODO REMOVE
+    # $dotfile->unlink_on_destroy(0);
+    binmode $dotfile, ':utf8';
+    print $dotfile join( "\n", @lines );
+    push( @cmd, $dotfile->filename );
+    run( \@cmd, ">", binary(), \$svg );
+    $svg = decode_utf8( $svg );
+    return $svg;
 }
 
+sub witnesses {
+    my $self = shift;
+    my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
+        $self->graph->vertices;
+    return @wits;
+}
+
+#### Methods for calculating phylogenetic trees ####
+
 before 'distance_trees' => sub {
     my $self = shift;
     my %args = @_;
@@ -79,9 +99,11 @@ before 'distance_trees' => sub {
         # We need to make a tree before we can return it.
         my( $ok, $result ) = $self->run_phylip_pars();
         if( $ok ) {
-            $self->_save_distance_trees( _parse_newick( $result ) );
+            # Save the resulting trees
+            my $trees = _parse_newick( $result );
+            $self->_save_distance_trees( $trees );
         } else {
-            warn "Failed to calculate distance tree: $result";
+            warn "Failed to calculate distance trees: $result";
         }
     }
 };
@@ -95,7 +117,6 @@ sub make_character_matrix {
     my $table = $self->collation->make_alignment_table;
     # Push the names of the witnesses to initialize the rows of the matrix.
     my @matrix = map { [ $self->_normalize_ac( $_ ) ] } @{$table->[0]};
-    $DB::single = 1;
     foreach my $token_index ( 1 .. $#{$table} ) {
         # First implementation: make dumb alignment table, caring about
         # nothing except which reading is in which position.
@@ -104,7 +125,7 @@ sub make_character_matrix {
             push( @{$matrix[$idx]}, $chars[$idx] );
         }
     }
-    $self->_save_character_matrix( \@matrix );
+    return \@matrix;
 } 
 
 sub _normalize_ac {
@@ -140,15 +161,15 @@ sub convert_characters {
 
 sub phylip_pars_input {
     my $self = shift;
-    $self->make_character_matrix unless $self->has_character_matrix;
-    my $matrix = '';
-    my $rows = scalar @{$self->character_matrix};
-    my $columns = scalar @{$self->character_matrix->[0]} - 1;
-    $matrix .= "\t$rows\t$columns\n";
-    foreach my $row ( @{$self->character_matrix} ) {
-        $matrix .= join( '', @$row ) . "\n";
+    my $character_matrix = $self->make_character_matrix;
+    my $input = '';
+    my $rows = scalar @{$character_matrix};
+    my $columns = scalar @{$character_matrix->[0]} - 1;
+    $input .= "\t$rows\t$columns\n";
+    foreach my $row ( @{$character_matrix} ) {
+        $input .= join( '', @$row ) . "\n";
     }
-    return $matrix;
+    return $input;
 }
 
 sub run_phylip_pars {