From: Tara L Andrews Date: Fri, 3 Feb 2012 20:34:24 +0000 (+0100) Subject: remove distance tree stuff from Stemma object X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9457207bd8e172d841358f5687b2b6208f8f3892;p=scpubgit%2Fstemmatology.git remove distance tree stuff from Stemma object --- diff --git a/lib/Text/Tradition/Stemma.pm b/lib/Text/Tradition/Stemma.pm index b875e4e..3969c6d 100644 --- a/lib/Text/Tradition/Stemma.pm +++ b/lib/Text/Tradition/Stemma.pm @@ -107,20 +107,7 @@ has graph => ( isa => 'Graph', predicate => 'has_graph', ); - -has distance_trees => ( - is => 'ro', - isa => 'ArrayRef[Graph]', - writer => '_save_distance_trees', - predicate => 'has_distance_trees', - ); - -has distance_program => ( - is => 'rw', - isa => 'Str', - default => '', - ); - + sub BUILD { my( $self, $args ) = @_; # If we have been handed a dotfile, initialize it into a graph. @@ -299,47 +286,6 @@ sub witnesses { return @wits; } -=head2 distance_trees( program => $program ) - -Returns a set of undirected graphs, which are the result of running a distance -tree calculation program on the collation. Currently the only supported -program is phylip_pars. - -=cut - -#### Methods for calculating phylogenetic trees #### - -before 'distance_trees' => sub { - my $self = shift; - my %args = ( - 'program' => 'phylip_pars', - @_ ); - # TODO allow specification of method for calculating distance tree - if( !$self->has_distance_trees - || $args{'program'} ne $self->distance_program ) { - # We need to make a tree before we can return it. - my $dsub = 'run_' . $args{'program'}; - my $result = $self->$dsub(); # this might throw an error - catch it? - # Save the resulting trees - my $trees = parse_newick( $result ); - $self->_save_distance_trees( $trees ); - $self->distance_program( $args{'program'} ); - } -}; - -=head2 run_phylip_pars - -Runs Phylip Pars on the collation, returning the results in Newick format. -Used for the distance_trees calculation. - -=cut - -sub run_phylip_pars { - my $self = shift; - my $cdata = character_input( $self->collation->make_alignment_table() ); - return phylip_pars( $cdata ); -} - sub throw { Text::Tradition::Error->throw( 'ident' => 'Stemma error', diff --git a/lib/Text/Tradition/StemmaUtil.pm b/lib/Text/Tradition/StemmaUtil.pm index e48c0ff..295110d 100644 --- a/lib/Text/Tradition/StemmaUtil.pm +++ b/lib/Text/Tradition/StemmaUtil.pm @@ -13,8 +13,7 @@ use Graph; use Graph::Reader::Dot; use IPC::Run qw/ run binary /; use Text::Tradition::Error; -@EXPORT_OK = qw/ make_character_matrix character_input phylip_pars - parse_newick newick_to_svg /; +@EXPORT_OK = qw/ character_input phylip_pars parse_newick newick_to_svg /; =head1 NAME @@ -27,8 +26,27 @@ text collations. =head1 SUBROUTINES +=head2 character_input( $alignment_table ) + +Returns a character matrix string suitable for Phylip programs, which +corresponds to the given alignment table. See Text::Tradition::Collation +for a description of the alignment table format. + =cut +sub character_input { + my $table = shift; + my $character_matrix = _make_character_matrix( $table ); + 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 $input; +} + sub _make_character_matrix { my( $table ) = @_; # Push the names of the witnesses to initialize the rows of the matrix. @@ -91,27 +109,6 @@ sub _convert_characters { return @chars; } -=head2 character_input( $alignment_table ) - -Returns a character matrix string suitable for Phylip programs, which -corresponds to the given alignment table. See Text::Tradition::Collation -for a description of the alignment table format. - -=cut - -sub character_input { - my $table = shift; - my $character_matrix = _make_character_matrix( $table ); - 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 $input; -} - =head2 phylip_pars( $character_matrix ) Runs Phylip Pars on the given character matrix. Returns results in Newick format. diff --git a/t/stemma.t b/t/stemma.t index 23fd8d9..45f1f3f 100644 --- a/t/stemma.t +++ b/t/stemma.t @@ -5,7 +5,7 @@ use File::Which; use Test::More; use lib 'lib'; use Text::Tradition; -use Text::Tradition::StemmaUtil; +use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /; use XML::LibXML; use XML::LibXML::XPathContext; @@ -30,35 +30,36 @@ 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 -my $m = Text::Tradition::StemmaUtil::_make_character_matrix( $c->make_alignment_table() ); +my $mstr = character_input( $c->make_alignment_table() ); ## check number of rows -is( scalar @$m, 3, "Found three witnesses in char matrix" ); +my @mlines = split( "\n", $mstr ); +my $msig = shift @mlines; +my( $rows, $chars ) = $msig =~ /(\d+)\s+(\d+)/; +is( $rows, 3, "Found three witnesses in char matrix" ); ## check number of columns -is( scalar( @{$m->[0]} ), 19, "Found 18 rows plus sigla in char matrix" ); +is( $chars, 18, "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" ); +foreach my $ml ( @mlines ) { + my( $wit, $chars ) = split( /\s+/, $ml ); + is( $chars, $expected{$wit}, "Row for witness $wit is correct" ); } # Test that pars runs SKIP: { skip "pars not in path", 3 unless File::Which::which('pars'); - my( $status, $tree ) = $stemma->run_phylip_pars(); - ok( $status, "pars ran successfully" ); - print STDERR "Error was $tree\n" unless $status; - + my $newick = phylip_pars( $mstr ); + ok( $newick, "pars ran successfully" ); + + my $trees = parse_newick( $newick ); # Test that we get a tree - is( scalar @{$stemma->distance_trees}, 1, "Got a single tree" ); + is( scalar @$trees, 1, "Got a single tree" ); # Test that the tree has all our witnesses - $tree = $stemma->distance_trees->[0]; + my $tree = $trees->[0]; my @leaves = grep { $tree->degree( $_ ) == 1 } $tree->vertices; is( scalar @leaves, 3, "All witnesses in the tree" ); }