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.
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',
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
=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.
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.
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;
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" );
}
projects / scpubgit/stemmatology.git / commitdiff