File Coverage

blib/lib/Bio/Phylo/Parsers/Figtree.pm

Criterion	Covered	Total	%
statement	83	86	96.5
branch	16	20	80.0
condition	8	9	88.8
subroutine	10	10	100.0
pod			n/a
total	117	125	93.6

package Bio::Phylo::Parsers::Figtree;
use strict;
use base 'Bio::Phylo::Parsers::Abstract';
use Bio::Phylo::Util::CONSTANT qw':namespaces :objecttypes';
use Bio::Phylo::Factory;
use Bio::Phylo::IO 'parse_tree';
use Bio::Phylo::Util::Logger ':levels';

my $fac = Bio::Phylo::Factory->new;
my $log = Bio::Phylo::Util::Logger->new;
my $ns  = _NS_FIGTREE_;
my $pre = 'fig';

=head1 NAME

Bio::Phylo::Parsers::Figtree - Parser used by Bio::Phylo::IO, no serviceable parts inside

=head1 DESCRIPTION

This module parses annotated trees in NEXUS format as interpreted by FigTree
(L), i.e. trees where nodes have
additional 'hot comments' attached to them in the tree description. The
implementation assumes syntax as follows:

 [&minmax={0.1231,0.3254},rate=0.0075583392800736]

I.e. the first token inside the comments is an ampersand, the annotations are
comma-separated key/value pairs, where ranges are between curly parentheses.

The annotations are stored as meta objects, e.g.:

 $node->get_meta_object('fig:rate'); # 0.0075583392800736
 $node->get_meta_object('fig:minmax_min'); # 0.1231
 $node->get_meta_object('fig:minmax_max'); # 0.3254

Annotations that have non-alphanumerical symbols in them will have these removed
from them. For example, C becomes two annotations:
C and C.

=cut

sub _parse {
    my $self = shift;
	my $fh = $self->_handle;
	my $forest = $fac->create_forest;
	$forest->set_namespaces( $pre => $ns );
	my $tree_block;
	my $tree_string;
	my %translate;
	while(<$fh>) {
		$tree_block++ if /BEGIN TREES;/i;
		if ( /^\s*TREE (\S+) = \[&([RU])\] (.+)$/i ) {
			my ( $name, $rooted, $newick ) = ( $1, $2, $3 );
			$tree_string++;
			my $tree = parse_tree(
				'-format'          => 'newick',
				'-string'          => $newick,
				'-ignore_comments' => 1,
			);
			$tree->set_as_unrooted if $rooted eq 'U';
			$tree->set_name( $name );
			$self->_post_process( $tree );
			for my $tip ( @{ $tree->get_terminals } ) {
				my $name = $tip->get_name;
				$tip->set_name( $translate{$name} );
			}
			$forest->insert($tree);
		}
		if ( $tree_block and not $tree_string and /\s+(\d+)\s+(.+)/ ) {
			my ( $id, $name ) = ( $1, $2 );
			$name =~ s/[,;]$//;
			$translate{$id} = $name;
		}
	}
	return $forest;
}

sub _post_process {
	my ( $self, $tree ) = @_;
	$log->debug("going to post-process tree");
    $tree->visit(sub{
    	my $n = shift;
    	my $name = $n->get_name;
    	$name =~ s/\\//g;
    	$log->debug("name: $name");
    	if ( $name =~ /\[/ and $name =~ /^([^\[]*?)\[(.+?)\]$/ ) {
    		my ( $trimmed, $comments ) = ( $1, $2 );
    		$n->set_name( $trimmed );
    		$log->debug("trimmed name: $trimmed");

    		# "hot comments" start with ampersand. ignore if not.
    		if ( $comments =~ /^&(.+)/ ) {
    			$log->debug("hot comments: $comments");
    			$comments = $1;

    			# string needs to be fully eaten up
    			COMMENT: while( my $old_length = length($comments) ) {

    				# grab the next key
    				if ( $comments =~ /^(.+?)=/ ) {
    					my $key = $1;

    					# remove the key and the =
    					$comments =~ s/^\Q$key\E=//;
						$key =~ s/\%//;

    					# value is a comma separated range
    					if ( $comments =~ /^{([^}]+)}/ ) {
    						my $value = $1;
							my ( $min, $max ) = split /,/, $value;
							_meta( $n, "${key}_min" => $min );
							_meta( $n, "${key}_max" => $max );
							$log->debug("$key: $min .. $max");

    						# remove the range
    						$value = "{$value}";
    						$comments =~ s/^\Q$value\E//;
    					}

    					# value is a scalar
    					elsif ( $comments =~ /^([^,]+)/ ) {
    						my $value = $1;
							_meta( $n, $key => $value );
    						$comments =~ s/^\Q$value\E//;
    						$log->debug("$key: $value");
    					}

    					# remove trailing comma, if any
    					$comments =~ s/^,//;
    				}
    				if ( $old_length == length($comments) ) {
    					$log->warn("couldn't parse newick comment: $comments");
    					last COMMENT;
    				}
    			}
    		}
    		else {
    			$log->debug("not hot: $comments");
    		}
    	}
    });
}

sub _meta {
	my ( $node, $key, $value ) = @_;
	#if ( $key =~ /[()+]/ ) {
		$log->info("cleaning up CURIE candidate $key");
		$key =~ s/\(/_/g;
		$key =~ s/\)/_/g;
		$key =~ s/\+/_/g;
		$key =~ s/\!//;
	#}
	$node->add_meta(
		$fac->create_meta( '-triple' => { "${pre}:${key}" => $value } )
	);
}


# podinherit_insert_token

=head1 SEE ALSO

There is a mailing list at L
for any user or developer questions and discussions.

=over

=item L

The figtree parser is called by the L object.
Look there to learn how to parse phylogenetic data files in general.

=item L

Also see the manual: L and L

=back

=head1 CITATION

If you use Bio::Phylo in published research, please cite it:

B, B, B, B
and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
I B<12>:63.
L

=cut

1;