1 package Text::Tradition::Stemma;
4 use Encode qw( decode_utf8 );
8 use Graph::Reader::Dot;
9 use IPC::Run qw/ run binary /;
14 isa => 'Text::Tradition::Collation',
22 predicate => 'has_graph',
25 has distance_trees => (
27 isa => 'ArrayRef[Graph]',
28 writer => '_save_distance_trees',
29 predicate => 'has_distance_trees',
33 my( $self, $args ) = @_;
34 # If we have been handed a dotfile, initialize it into a graph.
35 if( exists $args->{'dot'} ) {
36 $self->graph_from_dot( $args->{'dot'} );
41 my( $self, $dotfh ) = @_;
43 binmode( $dotfh, ':utf8' );
44 my $reader = Graph::Reader::Dot->new();
45 my $graph = $reader->read_graph( $dotfh );
47 $self->graph( $graph );
48 # Go through the nodes and set any non-hypothetical node to extant.
49 foreach my $v ( $self->graph->vertices ) {
50 $self->graph->set_vertex_attribute( $v, 'class', 'extant' )
51 unless $self->graph->has_vertex_attribute( $v, 'class' );
54 warn "Failed to parse dot in $dotfh";
59 my( $self, $opts ) = @_;
61 # Get default and specified options
65 'hshape' => 'plaintext', # Shape for the hypothetical nodes
68 'fillcolor' => 'white',
69 'shape' => 'ellipse', # Shape for the extant nodes
72 'arrowhead' => 'open',
74 @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
76 @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
78 @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
82 push( @dotlines, 'digraph stemma {' );
83 ## Print out the global attributes
84 push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
85 push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
86 ## Delete our special attributes from the node set before continuing
87 my $hshape = delete $nodeopts{'hshape'};
88 my $htext = delete $nodeopts{'htext'};
89 push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
91 # Add each of the nodes.
92 foreach my $n ( $self->graph->vertices ) {
93 if( $self->graph->get_vertex_attribute( $n, 'class' ) eq 'hypothetical' ) {
94 # Apply our display settings for hypothetical nodes.
95 push( @dotlines, _make_dotline( $n, 'shape' => $hshape, 'label' => $htext ) );
97 # Use the default display settings.
98 push( @dotlines, " $n;" );
101 # Add each of our edges.
102 foreach my $e ( $self->graph->edges ) {
103 my( $from, $to ) = @$e;
104 push( @dotlines, " $from -> $to;" );
106 push( @dotlines, '}' );
108 return join( "\n", @dotlines );
112 # Another version of dot output meant for graph editing, thus
117 push( @dotlines, 'digraph stemma {' );
118 my @real; # A cheap sort
119 foreach my $n ( sort $self->graph->vertices ) {
120 my $c = $self->graph->get_vertex_attribute( $n, 'class' );
121 $c = 'extant' unless $c;
122 if( $c eq 'extant' ) {
125 push( @dotlines, _make_dotline( $n, 'class' => $c ) );
128 # Now do the real ones
129 foreach my $n ( @real ) {
130 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
132 foreach my $e ( sort _by_vertex $self->graph->edges ) {
133 my( $from, $to ) = @$e;
134 push( @dotlines, " $from -> $to;" );
136 push( @dotlines, '}' );
137 return join( "\n", @dotlines );
141 my( $obj, %attr ) = @_;
143 foreach my $k ( keys %attr ) {
146 push( @pairs, "$k=\"$v\"" );
148 return sprintf( " %s [ %s ];", $obj, join( ', ', @pairs ) );
152 return $a->[0].$a->[1] cmp $b->[0].$b->[1];
155 # Render the stemma as SVG.
157 my( $self, $opts ) = @_;
158 my $dot = $self->as_dot( $opts );
159 my @cmd = qw/dot -Tsvg/;
161 my $dotfile = File::Temp->new();
163 # $dotfile->unlink_on_destroy(0);
164 binmode $dotfile, ':utf8';
166 push( @cmd, $dotfile->filename );
167 run( \@cmd, ">", binary(), \$svg );
168 $svg = decode_utf8( $svg );
174 my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
175 $self->graph->vertices;
179 #### Methods for calculating phylogenetic trees ####
181 before 'distance_trees' => sub {
184 # TODO allow specification of method for calculating distance tree
185 if( $args{'recalc'} || !$self->has_distance_trees ) {
186 # We need to make a tree before we can return it.
187 my( $ok, $result ) = $self->run_phylip_pars();
189 # Save the resulting trees
190 my $trees = _parse_newick( $result );
191 $self->_save_distance_trees( $trees );
193 warn "Failed to calculate distance trees: $result";
198 sub make_character_matrix {
200 unless( $self->collation->linear ) {
201 warn "Need a linear graph in order to make an alignment table";
204 my $table = $self->collation->make_alignment_table;
205 # Push the names of the witnesses to initialize the rows of the matrix.
206 my @matrix = map { [ $self->_normalize_ac( $_ ) ] } @{$table->[0]};
207 foreach my $token_index ( 1 .. $#{$table} ) {
208 # First implementation: make dumb alignment table, caring about
209 # nothing except which reading is in which position.
210 my @chars = convert_characters( $table->[$token_index] );
211 foreach my $idx ( 0 .. $#matrix ) {
212 push( @{$matrix[$idx]}, $chars[$idx] );
219 my( $self, $witname ) = @_;
220 my $ac = $self->collation->ac_label;
221 if( $witname =~ /(.*)\Q$ac\E$/ ) {
222 $witname = $1 . '_ac';
224 return sprintf( "%-10s", $witname );
227 sub convert_characters {
229 # This is a simple algorithm that treats every reading as different.
230 # Eventually we will want to be able to specify how relationships
231 # affect the character matrix.
232 my %unique = ( '__UNDEF__' => 'X',
237 foreach my $word ( @$row ) {
238 if( $word && !exists $unique{$word} ) {
239 $unique{$word} = chr( 65 + $ctr );
242 $count{$word}++ if $word;
244 # Try to keep variants under 8 by lacunizing any singletons.
245 if( scalar( keys %unique ) > 8 ) {
246 foreach my $word ( keys %count ) {
247 if( $count{$word} == 1 ) {
248 $unique{$word} = '?';
252 my %u = reverse %unique;
253 if( scalar( keys %u ) > 8 ) {
254 warn "Have more than 8 variants on this location; phylip will break";
256 my @chars = map { $_ ? $unique{$_} : $unique{'__UNDEF__' } } @$row;
260 sub phylip_pars_input {
262 my $character_matrix = $self->make_character_matrix;
264 my $rows = scalar @{$character_matrix};
265 my $columns = scalar @{$character_matrix->[0]} - 1;
266 $input .= "\t$rows\t$columns\n";
267 foreach my $row ( @{$character_matrix} ) {
268 $input .= join( '', @$row ) . "\n";
273 sub run_phylip_pars {
276 # Set up a temporary directory for all the default Phylip files.
277 my $phylip_dir = File::Temp->newdir();
278 # $phylip_dir->unlink_on_destroy(0);
279 # We need an infile, and we need a command input file.
280 open( MATRIX, ">$phylip_dir/infile" ) or die "Could not write $phylip_dir/infile";
281 print MATRIX $self->phylip_pars_input();
284 open( CMD, ">$phylip_dir/cmdfile" ) or die "Could not write $phylip_dir/cmdfile";
285 ## TODO any configuration parameters we want to set here
286 # U Search for best tree? Yes
287 # S Search option? More thorough search
288 # V Number of trees to save? 100
289 # J Randomize input order of species? No. Use input order
290 # O Outgroup root? No, use as outgroup species 1
291 # T Use Threshold parsimony? No, use ordinary parsimony
292 # W Sites weighted? No
293 # M Analyze multiple data sets? No
294 # I Input species interleaved? Yes
295 # 0 Terminal type (IBM PC, ANSI, none)? ANSI
296 # 1 Print out the data at start of run No
297 # 2 Print indications of progress of run Yes
298 # 3 Print out tree Yes
299 # 4 Print out steps in each site No
300 # 5 Print character at all nodes of tree No
301 # 6 Write out trees onto tree file? Yes
305 # And then we run the program.
307 my $PHYLIP_PATH = '/Users/tla/Projects/phylip-3.69/exe';
308 my $program = "pars";
309 if( $^O eq 'darwin' ) {
310 $program = "$PHYLIP_PATH/$program.app/Contents/MacOS/$program";
312 $program = "$PHYLIP_PATH/$program";
316 # We need to run it in our temporary directory where we have created
317 # all the expected files.
318 local $CWD = $phylip_dir;
319 my @cmd = ( $program );
320 run \@cmd, '<', 'cmdfile', '>', '/dev/null';
322 # Now our output should be in 'outfile' and our tree in 'outtree',
323 # both in the temp directory.
326 if( -f "$phylip_dir/outtree" ) {
327 open( TREE, "$phylip_dir/outtree" ) or die "Could not open outtree for read";
331 return( 1, join( '', @outtree ) ) if @outtree;
334 if( -f "$phylip_dir/outfile" ) {
335 open( OUTPUT, "$phylip_dir/outfile" ) or die "Could not open output for read";
339 push( @error, "Neither outtree nor output file was produced!" );
341 return( undef, join( '', @error ) );
347 # Parse the result into a tree
348 my $forest = Bio::Phylo::IO->parse(
352 # Turn the tree into a graph, starting with the root node
353 foreach my $tree ( @{$forest->get_entities} ) {
354 push( @trees, _graph_from_bio( $tree ) );
359 sub _graph_from_bio {
361 my $graph = Graph->new( 'undirected' => 1 );
362 # Give all the intermediate anonymous nodes a name.
364 foreach my $n ( @{$tree->get_entities} ) {
365 next if $n->get_name;
366 $n->set_name( $i++ );
368 my $root = $tree->get_root->get_name;
369 $graph->add_vertex( $root );
370 _add_tree_children( $graph, $root, $tree->get_root->get_children() );
374 sub _add_tree_children {
375 my( $graph, $parent, $tree_children ) = @_;
376 foreach my $c ( @$tree_children ) {
377 my $child = $c->get_name;
378 $graph->add_vertex( $child );
379 $graph->add_path( $parent, $child );
380 _add_tree_children( $graph, $child, $c->get_children() );
385 __PACKAGE__->meta->make_immutable;