# Disable deprecated behavior needed by old applications
disable_component_resolution_regex_fallback => 1,
default_view => 'TT',
+ 'View::JSON' => {
+ expose_stash => 'result',
+ },
);
# Start the application
my( $self, $c ) = @_;
my $m = $c->model('Directory');
my $tradition = $m->tradition( $c->request->params->{'textid'} );
- $c->stash->{alignment} = $tradition->collation->make_alignment_table( 'refs' );
- $c->stash->{template} = 'relationships.tt';
+ my $table = $tradition->collation->make_alignment_table();
+ my $witlist = map { $_->{'witness'} } @{$table->{'alignment'}};
+ $c->stash->{witnesses} = $witlist;
+ $c->stash->{alignment} = $table;
+ $c->stash->{template} = 'relate.tt';
}
=head2 stexaminer
$c->stash->{conflict} = $t->{'conflict_count'};
}
+=head2 alignment_table
+
+Return a JSON alignment table of a given text.
+
+=cut
+
+sub alignment_table :Local {
+ my( $self, $c ) = @_;
+ my $m = $c->model( 'Directory' );
+ my $tradition = $m->tradition( $c->request->params->{'textid'} );
+ my $table = $tradition->collation->make_alignment_table();
+ $c->stash->{'result'} = $table;
+ $c->forward-( 'View::JSON' );
+}
+
=head1 OPENSOCIAL URLs
=head2 view_table
use Moose;
use namespace::autoclean;
use File::Temp;
+use JSON;
use Text::Tradition::Collation;
-use Text::Tradition::Stemma;
+use Text::Tradition::StemmaUtil qw/ character_input phylip_pars newick_to_svg /;
BEGIN { extends 'Catalyst::Controller' }
$c->forward( "View::SVG" );
}
-=head2 end
+=head2 character_matrix
-Attempt to render a view, if needed.
+Given an alignment table in JSON form, in the parameter 'alignment', returns a
+character matrix suitable for input to Phylip PARS.
=cut
-sub end : ActionClass('RenderView') {}
+sub character_matrix :Local {
+ my( $self, $c ) = @_;
+ my $json = $c->request->params->{'alignment'};
+ $c->log->debug( $json );
+ my $table = from_json( $json );
+ my $matrix = character_input( $table );
+ $c->stash->{'result'} = { 'matrix' => $matrix };
+ $c->forward( 'View::JSON' );
+}
+
+=head2 run_pars
+
+Takes either an alignment table in JSON format (passed as the parameter 'alignment')
+or a character matrix Phylip accepts (passed as the parameter 'matrix'). Returns
+either the Newick-format answer or an SVG representation of the graph.
+
+=cut
+
+sub run_pars :Local {
+ my( $self, $c ) = @_;
+ my $error;
+ my $view = 'View::JSON';
+ my $matrix;
+ if( $c->request->param('matrix') ) {
+ $matrix = $c->request->param('matrix');
+ } elsif( $c->request->param('alignment') ) {
+ # Make the matrix from the alignment
+ my $table = from_json( $c->request->param('alignment') );
+ $matrix = character_input( $table );
+ } else {
+ $error = "Must pass either an alignment or a matrix";
+ }
+
+ # Got the matrix, so try to run pars.
+ my( $result, $output );
+ unless( $error ) {
+ ( $result, $output ) = phylip_pars( $matrix );
+ $error = $output unless( $result );
+ }
+
+ # Did we want newick or a graph?
+ unless( $error ) {
+ my $format = 'newick';
+ $format = $c->request->param('format') if $c->request->param('format');
+ if( $format eq 'svg' ) {
+ # Do something
+ $c->stash->{'result'} = newick_to_svg( $output );
+ $view = 'View::SVG';
+ } elsif( $format ne 'newick' ) {
+ $error = "Requested output format $format unknown";
+ } else {
+ $c->stash->{'result'} = { 'tree' => $output };
+ }
+ }
+
+ if( $error ) {
+ $c->stash->{'error'} = $error;
+ } # else the stash is populated.
+ $c->forward( $view );
+}
=head1 AUTHOR
--- /dev/null
+package TreeOfTexts::View::JSON;
+
+use strict;
+use base 'Catalyst::View::JSON';
+
+=head1 NAME
+
+TreeOfTexts::View::JSON - Catalyst JSON View
+
+=head1 SYNOPSIS
+
+See L<TreeOfTexts>
+
+=head1 DESCRIPTION
+
+Catalyst JSON View.
+
+=head1 AUTHOR
+
+Tara Andrews
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+function getRelativePath( action ) {
+ path_elements = window.location.pathname.split('/');
+ if( path_elements[1].length > 0 ) {
+ return window.location.pathname.split('/')[1] + '/' + action;
+ } else {
+ return action;
+ }
+}
+
+function svgLoaded() {
+ $('ellipse').attr( {stroke:'black', fill:'#fff'} );
+ ncpath = getRelativePath( 'node_click' );
+ var jqjson = $.getJSON( ncpath, 'node_id=null', function(data) {
+ $.each( data, function(item, node_id_and_state) {
+ if( node_id_and_state[1] == 1 ) {
+ node_ellipse = $('.node').children('title').filter( function(index) {
+ return $(this).text() == node_id_and_state[0];
+ }).siblings('ellipse');
+ node_ellipse.attr( {stroke:'green', fill:'#b3f36d'} );
+ $('#constructedtext').append( node_ellipse.siblings('text').text() + ' ' );
+ } else {
+ if( node_id_and_state[1] == null ) {
+ $('#constructedtext').append( ' … ' );
+ }
+ }
+ });
+ add_node_objs();
+ });
+}
+
+function add_node_objs() {
+ $('ellipse[fill="#fff"]').each( function() {
+ $(this).data( 'node_obj', new node_obj( $(this) ) );
+ }
+ );
+}
+
+function get_node_obj( node_id ) {
+ return $('.node').children('title').filter( function(index) {
+ return $(this).text() == node_id;
+ }).siblings('ellipse').data( 'node_obj' );
+}
+
+function get_edge( edge_id ) {
+ return $('.edge').filter( function(index) {
+ return $(this).children( 'title' ).text() == $('<div/>').html(edge_id).text() ;
+ });
+}
+
+function node_obj(ellipse) {
+ this.ellipse = ellipse;
+ var self = this;
+
+ this.x = 0;
+ this.y = 0;
+ this.dx = 0;
+ this.dy = 0;
+ this.node_elements = node_elements_for(self.ellipse);
+ this.sub_nodes = [];
+ this.super_node = null;
+
+ this.dblclick_listener = function(evt) {
+ node_id = self.ellipse.siblings('title').text();
+ ncpath = getRelativePath( 'node_click' );
+ var jqjson = $.getJSON( ncpath, 'node_id=' + node_id, function(data) {
+ $('#constructedtext').empty();
+ $.each( data, function(item, node_id_and_state) {
+ node = get_node_obj( node_id_and_state[0] );
+ // 1 -> turn the associated SVG node on, put in the associate word in the text box.
+ // 0 -> turn SVG node off.
+ // null -> turn node off, put in ellipsis in text box at the corresponding place.
+ if( node_id_and_state[1] == 1 ) {
+//TODO: create test suite en refactor this in to more OO! (node and node_ellipse are 'conflated')
+ node_ellipse = $('.node').children('title').filter( function(index) {
+ return $(this).text() == node_id_and_state[0];
+ }).siblings('ellipse');
+ $('#constructedtext').append( node_ellipse.siblings('text').text() + ' ' );
+ if( node ) { node.set_draggable( false ) }
+ } else {
+ if( node ) { node.set_draggable( true ) };
+ if( node_id_and_state[1] == null ) {
+ $('#constructedtext').append( ' … ' );
+ }
+ }
+ });
+ });
+ }
+
+ this.set_draggable = function( draggable ) {
+ if( draggable ) {
+ self.ellipse.attr( {stroke:'black', fill:'#fff'} );
+ self.ellipse.mousedown( this.mousedown_listener );
+ self.ellipse.hover( this.enter_node, this.leave_node );
+ } else {
+ self.ellipse.unbind('mouseenter').unbind('mouseleave').unbind('mousedown');
+ self.ellipse.attr( {stroke:'green', fill:'#b3f36d'} );
+ }
+ }
+
+ this.mousedown_listener = function(evt) {
+ evt.stopPropagation();
+ self.x = evt.clientX;
+ self.y = evt.clientY;
+ $('body').mousemove( self.mousemove_listener );
+ $('body').mouseup( self.mouseup_listener );
+ self.ellipse.unbind('mouseenter').unbind('mouseleave')
+ self.ellipse.attr( 'fill', '#ff66ff' );
+ }
+
+ this.mousemove_listener = function(evt) {
+ self.dx = evt.clientX - self.x;
+ self.dy = evt.clientY - self.y;
+ self.move_elements();
+ }
+
+ this.mouseup_listener = function(evt) {
+ if( $('ellipse[fill="#ffccff"]').size() > 0 ) {
+ $('#source_node_id').val( self.ellipse.siblings('title').text() );
+ $('#target_node_id').val( $('ellipse[fill="#ffccff"]').siblings("title").text() );
+ $( '#dialog-form' ).dialog( 'open' );
+ };
+ $('body').unbind('mousemove');
+ $('body').unbind('mouseup');
+ self.ellipse.attr( 'fill', '#fff' );
+ self.ellipse.hover( self.enter_node, self.leave_node );
+ if( self.super_node ) {
+ self.eclipse();
+ } else {
+ self.reset_elements();
+ }
+ }
+
+ this.cpos = function() {
+ return { x: self.ellipse.attr('cx'), y: self.ellipse.attr('cy') };
+ }
+
+ this.get_g = function() {
+ return self.ellipse.parent('g');
+ }
+
+ this.stack_behind = function( collapse_info ) {
+ self.super_node = get_node_obj( collapse_info.target );
+ self.super_node.sub_nodes.push( self );
+ self.eclipse();
+ if( collapse_info.edges ) {
+ $.each( collapse_info.edges, function( source_edge_id, target_info ) {
+ get_edge(source_edge_id).attr( 'display', 'none' );
+ target_edge = get_edge(target_info.target);
+ // Unfortunately, the simple solution doesn't work...
+ // target_edge.children( 'text' ).replaceWith( '<text x="2270" y="-59.400001525878906"><tspan text-anchor="middle">A, B</tspan><tspan fill="red">, C</tspan></text>' );
+ // ..so we take the long and winding road...
+ var svg = $('#svgbasics').children('svg').svg().svg('get');
+ textx = target_edge.children( 'text' )[0].x.baseVal.getItem(0).value
+ texty = target_edge.children( 'text' )[0].y.baseVal.getItem(0).value
+ current_label = target_edge.children( 'text' ).text();
+ target_edge.children( 'text' ).remove();
+ texts = svg.createText();
+ texts.span(current_label, {'text-anchor': 'middle'}).span(target_info.label, {fill: 'red'});
+ svg.text(target_edge, textx, texty, texts);
+ });
+ }
+ }
+
+ this.eclipse = function() {
+ self.dx = new Number( self.super_node.cpos().x ) - new Number( self.cpos().x ) + ( 10 * (self.super_node.sub_nodes.indexOf(self) + 1) );
+ self.dy = new Number( self.super_node.cpos().y ) - new Number( self.cpos().y ) + ( 5 * (self.super_node.sub_nodes.indexOf(self) + 1) );
+ self.move_elements();
+ eclipse_index = self.super_node.sub_nodes.indexOf(self) - 1;
+ if( eclipse_index > -1 ) {
+ self.get_g().insertBefore( self.super_node.sub_nodes[eclipse_index].get_g() );
+ } else {
+ self.get_g().insertBefore( self.super_node.get_g() );
+ }
+ }
+
+ this.enter_node = function(evt) {
+ self.ellipse.attr( 'fill', '#ffccff' );
+ }
+
+ this.leave_node = function(evt) {
+ self.ellipse.attr( 'fill', '#fff' );
+ }
+
+ this.move_elements = function() {
+ $.each( self.node_elements, function(index, value) {
+ value.move(self.dx,self.dy);
+ });
+ }
+
+ this.reset_elements = function() {
+ $.each( self.node_elements, function(index, value) {
+ value.reset();
+ });
+ }
+
+ this.ellipse.dblclick( this.dblclick_listener );
+ self.set_draggable( true );
+}
+
+function svgshape( shape_element ) {
+ this.shape = shape_element;
+ this.move = function(dx,dy) {
+ this.shape.attr( "transform", "translate(" + dx + " " + dy + ")" );
+ }
+ this.reset = function() {
+ this.shape.attr( "transform", "translate( 0, 0 )" );
+ }
+}
+
+function svgpath( path_element ) {
+ this.path = path_element;
+ this.x = this.path.x;
+ this.y = this.path.y;
+ this.move = function(dx,dy) {
+ this.path.x = this.x + dx;
+ this.path.y = this.y + dy;
+ }
+ this.reset = function() {
+ this.path.x = this.x;
+ this.path.y = this.y;
+ }
+}
+
+function node_elements_for( ellipse ) {
+ node_elements = get_edge_elements_for( ellipse );
+ node_elements.push( new svgshape( ellipse.siblings('text') ) );
+ node_elements.push( new svgshape( ellipse ) );
+ return node_elements;
+}
+
+function get_edge_elements_for( ellipse ) {
+ edge_elements = new Array();
+ node_id = ellipse.siblings('title').text();
+ edge_in_pattern = new RegExp( node_id + '$' );
+ edge_out_pattern = new RegExp( '^' + node_id );
+ $.each( $('.edge').children('title'), function(index) {
+ title = $(this).text();
+ if( edge_in_pattern.test(title) ) {
+ edge_elements.push( new svgshape( $(this).siblings('polygon') ) );
+ path_segments = $(this).siblings('path')[0].pathSegList;
+ edge_elements.push( new svgpath( path_segments.getItem(path_segments.numberOfItems - 1) ) );
+ }
+ if( edge_out_pattern.test(title) ) {
+ path_segments = $(this).siblings('path')[0].pathSegList;
+ edge_elements.push( new svgpath( path_segments.getItem(0) ) );
+ }
+ });
+ return edge_elements;
+}
+
+$(document).ready(function () {
+ $('#graph').ajaxError(function() {
+ console.log( 'Oops.. something went wrong with trying to save this change. Please try again...' );
+ });
+ $('#graph').mousedown(function (event) {
+ $(this)
+ .data('down', true)
+ .data('x', event.clientX)
+ .data('scrollLeft', this.scrollLeft);
+ return false;
+ }).mouseup(function (event) {
+ $(this).data('down', false);
+ }).mousemove(function (event) {
+ if ($(this).data('down') == true ) {
+ this.scrollLeft = $(this).data('scrollLeft') + $(this).data('x') - event.clientX;
+ }
+ }).mousewheel(function (event, delta) {
+ this.scrollLeft -= (delta * 30);
+ }).css({
+ 'overflow' : 'hidden',
+ 'cursor' : '-moz-grab'
+ });
+ $( "#dialog-form" ).dialog({
+ autoOpen: false,
+ height: 150,
+ width: 250,
+ modal: true,
+ buttons: {
+ "Ok": function() {
+ form_values = $('#collapse_node_form').serialize()
+ ncpath = getRelativePath( 'node_collapse' );
+ var jqjson = $.getJSON( ncpath, form_values, function(data) {
+ $.each( data, function(item, collapse_info) {
+ get_node_obj( item ).stack_behind( collapse_info );
+ });
+ });
+ $( this ).dialog( "close" );
+ },
+ Cancel: function() {
+ $( this ).dialog( "close" );
+ }
+ },
+ close: function() {
+ $('#reason').val( "" ).removeClass( "ui-state-error" );
+ }
+ });
+});
+
+
+$(window).mouseout(function (event) {
+ if ($('#graph').data('down')) {
+ try {
+ if (event.originalTarget.nodeName == 'BODY' || event.originalTarget.nodeName == 'HTML') {
+ $('#graph').data('down', false);
+ }
+ } catch (e) {}
+ }
+});
+
+
--- /dev/null
+[% BLOCK js %]
+ <script type="text/javascript" src="js/jquery-1.4.4.min.js"></script>
+ <script type="text/javascript" src="js/jquery-ui-1.8.10.custom.min.js"></script>
+ <script type="text/javascript" src="js/interaction.js"></script>
+[% END %]
+
+<div id="row_directory">
+ <table>
+ <tr>
+[% FOREACH wit IN witnesses -%]
+ <th>[% wit %]</th>
+[% END -%]
+ </tr>
+[% FOREACH row IN alignment -%]
+ <tr>
+[% FOREACH item in row -%]
+ <td>[% item %]</td>
+[% END -%]
+ </tr>
+[% END -%]
+ </table>
+</div>
\ No newline at end of file
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+
+BEGIN { use_ok 'TreeOfTexts::View::JSON' }
+
+done_testing();
}
my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
my @all_pos = ( 1 .. $self->end->rank - 1 );
- foreach my $wit ( $self->tradition->witnesses ) {
+ foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
if( $include ) {
next unless $include->{$wit->sigil};
}
use Bio::Phylo::IO;
use Encode qw( decode_utf8 );
-use File::chdir;
use File::Temp;
-use File::Which;
use Graph;
use Graph::Reader::Dot;
use IPC::Run qw/ run binary /;
+use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
use Moose;
has collation => (
my( $ok, $result ) = $self->$dsub();
if( $ok ) {
# Save the resulting trees
- my $trees = _parse_newick( $result );
+ my $trees = parse_newick( $result );
$self->_save_distance_trees( $trees );
$self->distance_program( $args{'program'} );
} else {
}
}
};
-
-sub make_character_matrix {
- my $self = shift;
- unless( $self->collation->linear ) {
- warn "Need a linear graph in order to make an alignment table";
- return;
- }
- my $table = $self->collation->make_alignment_table;
- # Push the names of the witnesses to initialize the rows of the matrix.
- my @matrix = map { [ $self->_normalize_ac( $_->{'witness'} ) ] }
- @{$table->{'alignment'}};
- foreach my $token_index ( 0 .. $table->{'length'} - 1) {
- # First implementation: make dumb alignment table, caring about
- # nothing except which reading is in which position.
- my @pos_readings = map { $_->{'tokens'}->[$token_index] }
- @{$table->{'alignment'}};
- my @pos_text = map { $_ ? $_->{'t'} : $_ } @pos_readings;
- my @chars = convert_characters( \@pos_text );
- foreach my $idx ( 0 .. $#matrix ) {
- push( @{$matrix[$idx]}, $chars[$idx] );
- }
- }
- return \@matrix;
-}
-
-sub _normalize_ac {
- my( $self, $witname ) = @_;
- my $ac = $self->collation->ac_label;
- if( $witname =~ /(.*)\Q$ac\E$/ ) {
- $witname = $1 . '_ac';
- }
- return sprintf( "%-10s", $witname );
-}
-
-sub convert_characters {
- my $row = shift;
- # This is a simple algorithm that treats every reading as different.
- # Eventually we will want to be able to specify how relationships
- # affect the character matrix.
- my %unique = ( '__UNDEF__' => 'X',
- '#LACUNA#' => '?',
- );
- my %count;
- my $ctr = 0;
- foreach my $word ( @$row ) {
- if( $word && !exists $unique{$word} ) {
- $unique{$word} = chr( 65 + $ctr );
- $ctr++;
- }
- $count{$word}++ if $word;
- }
- # Try to keep variants under 8 by lacunizing any singletons.
- if( scalar( keys %unique ) > 8 ) {
- foreach my $word ( keys %count ) {
- if( $count{$word} == 1 ) {
- $unique{$word} = '?';
- }
- }
- }
- my %u = reverse %unique;
- if( scalar( keys %u ) > 8 ) {
- warn "Have more than 8 variants on this location; phylip will break";
- }
- my @chars = map { $_ ? $unique{$_} : $unique{'__UNDEF__' } } @$row;
- return @chars;
-}
-
-sub phylip_pars_input {
- my $self = shift;
- my $character_matrix = $self->make_character_matrix;
- 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 run_phylip_pars {
- my $self = shift;
-
- # Set up a temporary directory for all the default Phylip files.
- my $phylip_dir = File::Temp->newdir();
- # $phylip_dir->unlink_on_destroy(0);
- # We need an infile, and we need a command input file.
- open( MATRIX, ">$phylip_dir/infile" ) or die "Could not write $phylip_dir/infile";
- print MATRIX $self->phylip_pars_input();
- close MATRIX;
-
- open( CMD, ">$phylip_dir/cmdfile" ) or die "Could not write $phylip_dir/cmdfile";
- ## TODO any configuration parameters we want to set here
-# U Search for best tree? Yes
-# S Search option? More thorough search
-# V Number of trees to save? 100
-# J Randomize input order of species? No. Use input order
-# O Outgroup root? No, use as outgroup species 1
-# T Use Threshold parsimony? No, use ordinary parsimony
-# W Sites weighted? No
-# M Analyze multiple data sets? No
-# I Input species interleaved? Yes
-# 0 Terminal type (IBM PC, ANSI, none)? ANSI
-# 1 Print out the data at start of run No
-# 2 Print indications of progress of run Yes
-# 3 Print out tree Yes
-# 4 Print out steps in each site No
-# 5 Print character at all nodes of tree No
-# 6 Write out trees onto tree file? Yes
- print CMD "Y\n";
- close CMD;
-
- # And then we run the program.
- my $program = File::Which::which( 'pars' );
- unless( -x $program ) {
- return( undef, "Phylip pars not found in path" );
- }
-
- {
- # We need to run it in our temporary directory where we have created
- # all the expected files.
- local $CWD = $phylip_dir;
- my @cmd = ( $program );
- run \@cmd, '<', 'cmdfile', '>', '/dev/null';
- }
- # Now our output should be in 'outfile' and our tree in 'outtree',
- # both in the temp directory.
-
- my @outtree;
- if( -f "$phylip_dir/outtree" ) {
- open( TREE, "$phylip_dir/outtree" ) or die "Could not open outtree for read";
- @outtree = <TREE>;
- close TREE;
- }
- return( 1, join( '', @outtree ) ) if @outtree;
-
- my @error;
- if( -f "$phylip_dir/outfile" ) {
- open( OUTPUT, "$phylip_dir/outfile" ) or die "Could not open output for read";
- @error = <OUTPUT>;
- close OUTPUT;
- } else {
- push( @error, "Neither outtree nor output file was produced!" );
- }
- return( undef, join( '', @error ) );
-}
-
-sub _parse_newick {
- my $newick = shift;
- my @trees;
- # Parse the result into a tree
- my $forest = Bio::Phylo::IO->parse(
- -format => 'newick',
- -string => $newick,
- );
- # Turn the tree into a graph, starting with the root node
- foreach my $tree ( @{$forest->get_entities} ) {
- push( @trees, _graph_from_bio( $tree ) );
- }
- return \@trees;
-}
-
-sub _graph_from_bio {
- my $tree = shift;
- my $graph = Graph->new( 'undirected' => 1 );
- # Give all the intermediate anonymous nodes a name.
- my $i = 0;
- foreach my $n ( @{$tree->get_entities} ) {
- next if $n->get_name;
- $n->set_name( $i++ );
- }
- my $root = $tree->get_root->get_name;
- $graph->add_vertex( $root );
- _add_tree_children( $graph, $root, $tree->get_root->get_children() );
- return $graph;
-}
-
-sub _add_tree_children {
- my( $graph, $parent, $tree_children ) = @_;
- foreach my $c ( @$tree_children ) {
- my $child = $c->get_name;
- $graph->add_vertex( $child );
- $graph->add_path( $parent, $child );
- _add_tree_children( $graph, $child, $c->get_children() );
- }
+ my $self = shift;
+ my $cdata = character_input( $self->collation->make_alignment_table() );
+ return phylip_pars( $cdata );
}
no Moose;
--- /dev/null
+package Text::Tradition::StemmaUtil;
+
+use strict;
+use warnings;
+use Exporter 'import';
+use vars qw/ @EXPORT_OK /;
+use Bio::Phylo::IO;
+use Encode qw( decode_utf8 );
+use File::chdir;
+use File::Temp;
+use File::Which;
+use Graph;
+use Graph::Reader::Dot;
+use IPC::Run qw/ run binary /;
+@EXPORT_OK = qw/ make_character_matrix character_input phylip_pars
+ parse_newick newick_to_svg /;
+
+sub make_character_matrix {
+ my( $table ) = @_;
+ # Push the names of the witnesses to initialize the rows of the matrix.
+ my @matrix = map { [ _normalize_witname( $_->{'witness'} ) ] }
+ @{$table->{'alignment'}};
+ foreach my $token_index ( 0 .. $table->{'length'} - 1) {
+ # First implementation: make dumb alignment table, caring about
+ # nothing except which reading is in which position.
+ my @pos_readings = map { $_->{'tokens'}->[$token_index] }
+ @{$table->{'alignment'}};
+ my @pos_text = map { $_ ? $_->{'t'} : $_ } @pos_readings;
+ my @chars = convert_characters( \@pos_text );
+ foreach my $idx ( 0 .. $#matrix ) {
+ push( @{$matrix[$idx]}, $chars[$idx] );
+ }
+ }
+ return \@matrix;
+}
+
+# Helper function to make the witness name something legal for pars
+
+sub _normalize_witname {
+ my( $witname ) = @_;
+ $witname =~ s/\s+/ /g;
+ $witname =~ s/[\[\]\(\)\:;,]//g;
+ $witname = substr( $witname, 0, 10 );
+ return sprintf( "%-10s", $witname );
+}
+
+sub convert_characters {
+ my $row = shift;
+ # This is a simple algorithm that treats every reading as different.
+ # Eventually we will want to be able to specify how relationships
+ # affect the character matrix.
+ my %unique = ( '__UNDEF__' => 'X',
+ '#LACUNA#' => '?',
+ );
+ my %count;
+ my $ctr = 0;
+ foreach my $word ( @$row ) {
+ if( $word && !exists $unique{$word} ) {
+ $unique{$word} = chr( 65 + $ctr );
+ $ctr++;
+ }
+ $count{$word}++ if $word;
+ }
+ # Try to keep variants under 8 by lacunizing any singletons.
+ if( scalar( keys %unique ) > 8 ) {
+ foreach my $word ( keys %count ) {
+ if( $count{$word} == 1 ) {
+ $unique{$word} = '?';
+ }
+ }
+ }
+ my %u = reverse %unique;
+ if( scalar( keys %u ) > 8 ) {
+ warn "Have more than 8 variants on this location; phylip will break";
+ }
+ my @chars = map { $_ ? $unique{$_} : $unique{'__UNDEF__' } } @$row;
+ return @chars;
+}
+
+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 phylip_pars {
+ my( $charmatrix ) = @_;
+ # Set up a temporary directory for all the default Phylip files.
+ my $phylip_dir = File::Temp->newdir();
+ # $phylip_dir->unlink_on_destroy(0);
+ # We need an infile, and we need a command input file.
+ open( MATRIX, ">$phylip_dir/infile" ) or die "Could not write $phylip_dir/infile";
+ print MATRIX $charmatrix;
+ close MATRIX;
+
+ open( CMD, ">$phylip_dir/cmdfile" ) or die "Could not write $phylip_dir/cmdfile";
+ ## TODO any configuration parameters we want to set here
+# U Search for best tree? Yes
+# S Search option? More thorough search
+# V Number of trees to save? 100
+# J Randomize input order of species? No. Use input order
+# O Outgroup root? No, use as outgroup species 1
+# T Use Threshold parsimony? No, use ordinary parsimony
+# W Sites weighted? No
+# M Analyze multiple data sets? No
+# I Input species interleaved? Yes
+# 0 Terminal type (IBM PC, ANSI, none)? ANSI
+# 1 Print out the data at start of run No
+# 2 Print indications of progress of run Yes
+# 3 Print out tree Yes
+# 4 Print out steps in each site No
+# 5 Print character at all nodes of tree No
+# 6 Write out trees onto tree file? Yes
+ print CMD "Y\n";
+ close CMD;
+
+ # And then we run the program.
+ my $program = File::Which::which( 'pars' );
+ unless( -x $program ) {
+ return( undef, "Phylip pars not found in path" );
+ }
+
+ {
+ # We need to run it in our temporary directory where we have created
+ # all the expected files.
+ local $CWD = $phylip_dir;
+ my @cmd = ( $program );
+ run \@cmd, '<', 'cmdfile', '>', '/dev/null';
+ }
+ # Now our output should be in 'outfile' and our tree in 'outtree',
+ # both in the temp directory.
+
+ my @outtree;
+ if( -f "$phylip_dir/outtree" ) {
+ open( TREE, "$phylip_dir/outtree" ) or die "Could not open outtree for read";
+ @outtree = <TREE>;
+ close TREE;
+ }
+ return( 1, join( '', @outtree ) ) if @outtree;
+
+ my @error;
+ if( -f "$phylip_dir/outfile" ) {
+ open( OUTPUT, "$phylip_dir/outfile" ) or die "Could not open output for read";
+ @error = <OUTPUT>;
+ close OUTPUT;
+ } else {
+ push( @error, "Neither outtree nor output file was produced!" );
+ }
+ return( undef, join( '', @error ) );
+}
+
+sub parse_newick {
+ my $newick = shift;
+ my @trees;
+ # Parse the result into a tree
+ my $forest = Bio::Phylo::IO->parse(
+ -format => 'newick',
+ -string => $newick,
+ );
+ # Turn the tree into a graph, starting with the root node
+ foreach my $tree ( @{$forest->get_entities} ) {
+ push( @trees, _graph_from_bio( $tree ) );
+ }
+ return \@trees;
+}
+
+sub newick_to_svg {
+ my $newick = shift;
+ my $program = File::Which::which( 'figtree' );
+ unless( -x $program ) {
+ warn "FigTree commandline utility not found in path";
+ return;
+ }
+ my $svg;
+ my $nfile = File::Temp->new();
+ print $nfile $newick;
+ close $nfile;
+ my @cmd = ( $program, '-graphic', 'SVG', $nfile );
+ run( \@cmd, ">", binary(), \$svg );
+ return decode_utf8( $svg );
+}
+
+sub _graph_from_bio {
+ my $tree = shift;
+ my $graph = Graph->new( 'undirected' => 1 );
+ # Give all the intermediate anonymous nodes a name.
+ my $i = 0;
+ foreach my $n ( @{$tree->get_entities} ) {
+ next if $n->get_name;
+ $n->set_name( $i++ );
+ }
+ my $root = $tree->get_root->get_name;
+ $graph->add_vertex( $root );
+ _add_tree_children( $graph, $root, $tree->get_root->get_children() );
+ return $graph;
+}
+
+sub _add_tree_children {
+ my( $graph, $parent, $tree_children ) = @_;
+ foreach my $c ( @$tree_children ) {
+ my $child = $c->get_name;
+ $graph->add_vertex( $child );
+ $graph->add_path( $parent, $child );
+ _add_tree_children( $graph, $child, $c->get_children() );
+ }
+}
use Test::More;
use lib 'lib';
use Text::Tradition;
+use Text::Tradition::StemmaUtil qw/ make_character_matrix /;
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 = $stemma->make_character_matrix();
+my $m = make_character_matrix( $c->make_alignment_table() );
## check number of rows
is( scalar @$m, 3, "Found three witnesses in char matrix" );
## check number of columns
projects / scpubgit/stemmatology.git / commitdiff