From: Tara L Andrews Date: Sun, 1 Jan 2012 01:57:09 +0000 (+0100) Subject: Get rid of Graph::Easy; add stemma tests X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a7c249ce334ba9d74af27aba82d8f29792250d7;p=scpubgit%2Fstemmatology.git Get rid of Graph::Easy; add stemma tests --- diff --git a/Makefile.PL b/Makefile.PL index b8ae9fd..826656c 100644 --- 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 --- 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 --- 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