Get rid of Graph::Easy; add stemma tests

diff --git a/Makefile.PL b/Makefile.PL
index b8ae9fd..826656c 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -9,8 +9,6 @@ requires( 'Algorithm::Diff' );
 requires( 'Bio::Phylo::IO' );
 requires( 'File::chdir' );
 requires( 'Graph' );
-requires( 'Graph::Convert' );   # TODO delete
-requires( 'Graph::Easy' );     # TODO delete
 requires( 'Graph::Reader::Dot' );
 requires( 'IPC::Run' );
 requires( 'KiokuDB::Backend::DBI' );

diff --git a/lib/Text/Tradition/Stemma.pm b/lib/Text/Tradition/Stemma.pm
index c90b536..9a53812 100644 (file)
--- a/lib/Text/Tradition/Stemma.pm
+++ b/lib/Text/Tradition/Stemma.pm
@@ -5,11 +5,9 @@ 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 binary /;
 use Moose;
-use Text::Balanced qw/ extract_bracketed /;
 
 has collation => (
     is => 'ro',
@@ -45,37 +43,114 @@ sub graph_from_dot {
        binmode( $dotfh, ':utf8' );
        my $reader = Graph::Reader::Dot->new();
        my $graph = $reader->read_graph( $dotfh );
-       $graph 
-               ? $self->graph( $graph ) 
-               : warn "Failed to parse dot in $dotfh";
+       if( $graph ) {
+               $self->graph( $graph );
+               # Go through the nodes and set any non-hypothetical node to extant.
+               foreach my $v ( $self->graph->vertices ) {
+                       $self->graph->set_vertex_attribute( $v, 'class', 'extant' )
+                               unless $self->graph->has_vertex_attribute( $v, 'class' );
+               }
+       } else {
+               warn "Failed to parse dot in $dotfh";
+       }
 }
 
 sub as_dot {
     my( $self, $opts ) = @_;
-    # TODO add options for display, someday
-    # TODO see what happens with Graph::Writer::Dot 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' );
+    
+    # Get default and specified options
+    my %graphopts = ();
+    my %nodeopts = (
+               'fontsize' => 11,
+               'hshape' => 'plaintext',        # Shape for the hypothetical nodes
+               'htext' => '*',
+               'style' => 'filled',
+               'fillcolor' => 'white',
+               'shape' => 'ellipse',   # Shape for the extant nodes
+       );
+       my %edgeopts = (
+               'arrowhead' => 'open',
+       );
+       @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}} 
+               if $opts->{'graph'};
+       @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}} 
+               if $opts->{'node'};
+       @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}} 
+               if $opts->{'edge'};
+
+       my @dotlines;
+       push( @dotlines, 'digraph stemma {' );
+       ## Print out the global attributes
+       push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
+       push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
+       ## Delete our special attributes from the node set before continuing
+       my $hshape = delete $nodeopts{'hshape'};
+       my $htext = delete $nodeopts{'htext'};
+       push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
+
+       # Add each of the nodes.
+    foreach my $n ( $self->graph->vertices ) {
+        if( $self->graph->get_vertex_attribute( $n, 'class' ) eq 'hypothetical' ) {
+               # Apply our display settings for hypothetical nodes.
+               push( @dotlines, _make_dotline( $n, 'shape' => $hshape, 'label' => $htext ) );
         } else {
-            $n->set_attribute( 'shape', 'ellipse' );
+               # Use the default display settings.
+            push( @dotlines, "  $n;" );
         }
     }
+    # Add each of our edges.
+    foreach my $e ( $self->graph->edges ) {
+       my( $from, $to ) = @$e;
+       push( @dotlines, "  $from -> $to;" );
+    }
+    push( @dotlines, '}' );
     
-    # 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 );
+    return join( "\n", @dotlines );
+}
+
+
+# Another version of dot output meant for graph editing, thus
+# much simpler.
+sub editable {
+       my $self = shift;
+       my @dotlines;
+       push( @dotlines, 'digraph stemma {' );
+       my @real; # A cheap sort
+    foreach my $n ( sort $self->graph->vertices ) {
+       my $c = $self->graph->get_vertex_attribute( $n, 'class' );
+       $c = 'extant' unless $c;
+       if( $c eq 'extant' ) {
+               push( @real, $n );
+       } else {
+                       push( @dotlines, _make_dotline( $n, 'class' => $c ) );
+               }
     }
-    return join( "\n", @lines );
+       # Now do the real ones
+       foreach my $n ( @real ) {
+               push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
+       }
+       foreach my $e ( sort _by_vertex $self->graph->edges ) {
+               my( $from, $to ) = @$e;
+               push( @dotlines, "  $from -> $to;" );
+       }
+    push( @dotlines, '}' );
+    return join( "\n", @dotlines );
+}
+
+sub _make_dotline {
+       my( $obj, %attr ) = @_;
+       my @pairs;
+       foreach my $k ( keys %attr ) {
+               my $v = $attr{$k};
+               $v =~ s/\"/\\\"/g;
+               push( @pairs, "$k=\"$v\"" );
+       }
+       return sprintf( "  %s [ %s ];", $obj, join( ', ', @pairs ) );
 }
        
+sub _by_vertex {
+       return $a->[0].$a->[1] cmp $b->[0].$b->[1];
+}
 
 # Render the stemma as SVG.
 sub as_svg {

diff --git a/t/stemma.t b/t/stemma.t
index 276e736..95b25e3 100644 (file)
--- a/t/stemma.t
+++ b/t/stemma.t
@@ -4,7 +4,6 @@ use strict; use warnings;
 use Test::More;
 use lib 'lib';
 use Text::Tradition;
-use Text::Tradition::Stemma;
 use XML::LibXML;
 use XML::LibXML::XPathContext;
 
@@ -15,15 +14,37 @@ my $tradition = Text::Tradition->new(
     'input' => 'CollateX',
     'file'  => $datafile,
     );
-my $stemma = Text::Tradition::Stemma->new( 'collation' => $tradition->collation );
+# Set up some relationships
+my $c = $tradition->collation;
+$c->add_relationship( 'n25', 'n26', { 'type' => 'spelling' } );
+$c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } );
+$c->add_relationship( 'n8', 'n13', { 'type' => 'spelling' } );
+$c->calculate_ranks();
+
+my $stemma = $tradition->add_stemma( 't/data/simple.dot' );
 
 # Test for object creation
 ok( $stemma->isa( 'Text::Tradition::Stemma' ), 'Got the right sort of object' );
+is( $stemma->graph, '1-2,1-A,2-B,2-C', "Got the correct graph" );
 
 # Test for character matrix creation
-$stemma->make_character_matrix();
+my $m = $stemma->make_character_matrix();
  ## check number of rows
+is( scalar @$m, 3, "Found three witnesses in char matrix" );
  ## check number of columns
+is( scalar( @{$m->[0]} ), 19, "Found 18 rows plus sigla in char matrix" );
+ ## check matrix
+my %expected = (
+       'A' => 'AAAAAAAXAAAAAAAAAA',
+       'B' => 'AXXXAAAAAABABAABAA',
+       'C' => 'AXXXAAAAABAAAAAXBB',
+       );
+my @wits = map { shift @$_; } @$m;
+map { s/\s+//g } @wits;
+foreach my $i ( 0 .. $#wits ) {
+       my $w = $wits[$i];
+       is( join( '', @{$m->[$i]} ), $expected{$w}, "Row for witness $w is correct" );
+}
 
 # Test that pars runs
 my( $status, $tree ) = $stemma->run_phylip_pars();
@@ -31,7 +52,19 @@ ok( $status, "pars ran successfully" );
 print STDERR "Error was $tree\n" unless $status;
 
 # Test that we get a tree
-
+is( scalar @{$stemma->distance_trees}, 1, "Got a single tree" );
 # Test that the tree has all our witnesses
+$tree = $stemma->distance_trees->[0];
+my @leaves = grep { $tree->degree( $_ ) == 1 } $tree->vertices;
+is( scalar @leaves, 3, "All witnesses in the tree" );
+
+# Test our dot output
+my $display = $stemma->as_dot();
+ok( $display =~ /digraph/, "Got a dot display graph" );
+ok( $display !~ /hypothetical/, "Graph is display rather than edit" );
+# Test our editable output
+my $editable = $stemma->editable();
+ok( $editable =~ /digraph/, "Got a dot edit graph" );
+ok( $editable =~ /hypothetical/, "Graph contains an edit class" );
 
 done_testing();
\ No newline at end of file