libbio-perl-perl 1.7.2-2 / usr / share / perl5 / Bio / NexmlIO.pm

# $Id: Nexml.pm 15889 2009-07-29 13:35:29Z chmille4 $
# BioPerl module for Bio::NexmlIO
#
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
#
# Cared for by Chase Miller <chmille4@gmail.com>
#
# Copyright Chase Miller
#
# You may distribute this module under the same terms as perl itself
#
# _history
# June 16, 2009  Largely rewritten by Chase Miller

# POD documentation - main docs before the code

=head1 NAME

Bio::NexmlIO - stream handler for NeXML documents

=head1 SYNOPSIS

    #Instantiate a Bio::Nexml object and link it to a file
    my $in_nexml = Bio::Nexml->new(-file => 'nexml_doc.xml', -format => 'Nexml');

	#Read in some data
	my $bptree1 = $in_nexml->next_tree();
	my $bpaln1  = $in_nexml->next_aln();
	my $bpseq1  = $in_nexml->next_seq();

	#Use/manipulate data
	...

	#Write data to nexml file
	my $out_nexml = Bio::Nexml->new(-file => '>new_nexml_doc.xml', -format => 'Nexml');
	$out_nexml->to_xml();
    


=head1 DESCRIPTION

Bio::NexmlIO is an I/O handler for a NeXML document.  A NeXML document can
represent three different data types: simple sequences, alignments,
and trees. NexmlIO has four main methods next_tree, next_seq,
next_aln, and write. NexmlIO returns bioperl seq, tree, and aln
objects which can be manipulated then passed to the write method of a
new NexmlIO instance to allow the creation of a NeXML document.

Each bioperl object contains all the information necessary to recreate
a Bio::Phylo::Taxa object, so each time a bioperl object is converted
to a biophylo object, the bioperl object is checked to see if its
associated taxa has already been created (against a hash using the
NexmlIO_ID and Taxa_ID to create a unique string). If not, it is
created; if so, that taxa object is used to link the Bio::Phylo tree
or matrix.

For more information on the NeXML format, see L<http://www.nexml.org>.

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to one
of the Bioperl mailing lists.

Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Support 

Please direct usage questions or support issues to the mailing list:

I<bioperl-l@bioperl.org>

rather than to the module maintainer directly. Many experienced and 
reponsive experts will be able look at the problem and quickly 
address it. Please include a thorough description of the problem 
with code and data examples if at all possible.

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution.  Bug reports can be submitted via the
web:

  https://github.com/bioperl/bioperl-live/issues

=head1 AUTHOR - Chase Miller

Email chmille4@gmail.com

=head1 CONTRIBUTORS 

Mark A. Jensen, maj -at- fortinbras -dot- com

=head1 APPENDIX

The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _

=cut

# Let the code begin...


package Bio::NexmlIO;
use strict;
#TODO Change this
use lib '..';

use Bio::SeqIO::nexml;
use Bio::AlignIO::nexml;
use Bio::TreeIO::nexml;
use Bio::Nexml::Factory;

use base qw(Bio::Root::IO);

my $nexml_fac = Bio::Nexml::Factory->new();

=head1 CONSTRUCTOR

=head2 new

 Title   : new
 Usage   : my $in_nexmlIO = Bio::NexmlIO->new(-file => 'data.nexml.xml');
 Function: Creates a L<Bio::NexmlIO> object linked to a stream
 Returns : a L<Bio::NexmlIO> object
 Args    : file name
 
 See L<Bio::Root::IO>

=cut

sub new {
    my($class,@args) = @_;
    my $self = $class->SUPER::new(@args);
    
    my %params = @args;
    my $file_string = $params{'-file'};
    
    #create unique ID by creating a scalar and using the memory address
    my $ID = bless \(my $dummy), "UniqueID";
    ($self->{'_ID'}) = sprintf("%s",\$ID) =~ /(0x[0-9a-fA-F]+)/;
    
    unless ($file_string =~ m/^\>/) {
        # Only pass filename if filehandle is not available,
        # or "Bio::Phylo" will create a new filehandle that ends
        # out of scope and can't be closed directly, leaving 2 open
        # filehandles for the same file (so file can't be deleted)
        my $file_arg;
        my $file_value;
        if (     exists $self->{'_filehandle'}
            and defined $self->{'_filehandle'}
            ) {
            $file_arg   = '-handle';
            $file_value = $self->{'_filehandle'};
        }
        else {
            $file_arg   = '-file';
            $file_value = $self->{'_file'};
        }

        $self->{'_doc'} = Bio::Phylo::IO->parse($file_arg     => $file_value,,
                                                '-format'     => 'nexml',
                                                '-as_project' => '1');
    }
    
    return $self;
}

=head2 doc

 Title   : doc
 Usage   : my $nexml_doc = $in_nexmlIO->doc();
 Function: returns a L<Bio::Phylo::Project> object that contains all the Bio::Phylo data objects parsed from the stream
 Returns : a L<Bio::Phylo::Project> object
 Args    : none

=cut

sub doc {
	my $self = shift;
	return $self->{'_doc'};
}

# Takes the Bio::Phylo::Project object and creats BioPerl trees, alns, and seqs from it
sub _parse {
	my ($self) = @_;
    
	$self->{'_treeiter'} = 0;
	$self->{'_seqiter'}  = 0;
	$self->{'_alniter'}  = 0;
    
	$self->{_trees} = $nexml_fac->create_bperl_tree($self);
	$self->{_alns}  = $nexml_fac->create_bperl_aln($self);
	$self->{_seqs}  = $nexml_fac->create_bperl_seq($self);
	my $taxa_array = $self->doc->get_taxa();
	
	$self->{'_parsed'}   = 1; #success
}

=head1 ITERATORS

=head2 next_tree

 Title   : next_tree
 Usage   : $tree = $stream->next_tree
 Function: Reads the next tree object from the stream and returns it.
 Returns : a L<Bio::Tree::Tree> object
 Args    : none

See L<Bio::Root::IO>, L<Bio::Tree::Tree>

=cut

sub next_tree {
	my $self = shift;
	$self->_parse unless $self->{'_parsed'};

	return $self->{'_trees'}->[ $self->{'_treeiter'}++ ];
}

=head2 next_seq

 Title   : next_seq
 Usage   : $seq = $stream->next_seq
 Function: Reads the next seq object from the stream and returns it.
 Returns : a L<Bio::Seq> object
 Args    : none

See L<Bio::Root::IO>, L<Bio::Seq>

=cut

sub next_seq {
	my $self = shift;
	unless ( $self->{'_parsed'} ) {
        $self->_parse;
    }
	return $self->{'_seqs'}->[ $self->{'_seqiter'}++ ];
}

=head2 next_aln

 Title   : next_aln
 Usage   : $aln = $stream->next_aln
 Function: Reads the next aln object from the stream and returns it.
 Returns : a L<Bio::SimpleAlign> object
 Args    : none

See L<Bio::Root::IO>, L<Bio::SimpleAlign>

=cut

sub next_aln {
	my $self = shift;
	unless ( $self->{'_parsed'} ) {
        $self->_parse;
    }
	return $self->{'_alns'}->[ $self->{'_alniter'}++ ];
}

sub _rewind {
    my $self = shift;
    my $elt = shift;
    $self->{"_${elt}iter"} = 0 if defined $self->{"_${elt}iter"};
    return 1;
}

=head2 rewind_seq

 Title   : rewind_seq
 Usage   : $stream->rewind_seq
 Function: Resets the stream for seqs
 Returns : none
 Args    : none

See L<Bio::Root::IO>, L<Bio::Seq>

=cut

sub rewind_seq { shift->_rewind('seq'); }

=head2 rewind_aln

 Title   : rewind_aln
 Usage   : $stream->rewind_aln
 Function: Resets the stream for alns
 Returns : none
 Args    : none

See L<Bio::Root::IO>, L<Bio::Simple::Align>

=cut

sub rewind_aln { shift->_rewind('aln'); }

=head2 rewind_tree

 Title   : rewind_tree
 Usage   : $stream->rewind_tree
 Function: Resets the stream for trees
 Returns : none
 Args    : none

See L<Bio::Root::IO>, L<Bio::tree::tree>

=cut

sub rewind_tree { shift->_rewind('tree'); }

=head2 write

 Title   : write
 Usage   : $stream->write(-alns => $alns,-seqs => $seqs,-trees => $trees)
 Function: converts BioPerl seq, tree, and aln objects into Bio::Phylo
           seq, tree, and aln objects, constructs a Bio::Phylo::Project 
           object made up of the newly created Bio::Phylo objects, and 
           writes the Bio::Phylo:Project object to the stream as a valid 
           nexml document
 Returns : none
 Args    : \@L<Bio::Seq>, \@L<Bio::SimpleAlign>, \@L<Bio::Tree::Tree>

See L<Bio::Root::IO>, L<Bio::tree::tree>, L<Bio::Seq>, L<Bio::SimpleAlign>

=cut

sub write {
	my ($self, @args) = @_;
	
	my %params = @args;
	
	my ($trees, $alns, $seqs) = @params{qw( -trees -alns -seqs )};
	my %taxa_hash = ();
	my %seq_matrices = ();

	my $proj_doc = Bio::Phylo::Factory->create_project();
	
	#convert trees to bio::Phylo objects
	my $forest = Bio::Phylo::Factory->create_forest();
	my @forests;
	my @taxa_array;
	my $ent;
	my $taxa_o;
	my $phylo_tree_o;
	
	foreach my $tree (@$trees) {
		my $nexml_id = $tree->get_tag_values('_NexmlIO_ID');
		$taxa_o = undef;
		if ( defined $taxa_hash{$nexml_id} ) {
			$taxa_o = $taxa_hash{$nexml_id};
		}
		else {
			($taxa_o) = $nexml_fac->create_bphylo_taxa($tree);
			$forest->set_taxa($taxa_o) if defined $taxa_o;
			$taxa_hash{$nexml_id} = $taxa_o;
		}
		
		($phylo_tree_o) = $nexml_fac->create_bphylo_tree($tree,  $taxa_o);
		
		$forest->insert($phylo_tree_o);
	}

	#convert matrices to Bio::Phylo objects
	my $matrices = Bio::Phylo::Matrices->new();
	my $phylo_matrix_o;
	
	foreach my $aln (@$alns)
	{
		$taxa_o = undef;
		if (defined $taxa_hash{ $aln->{_Nexml_ID} }) {
			$taxa_o = $taxa_hash{$aln->{_Nexml_ID}};
		}
		else {
			($taxa_o) = $nexml_fac->create_bphylo_taxa($aln);
			$taxa_hash{$aln->{_Nexml_ID}} = $taxa_o;
		}
		
		($phylo_matrix_o) = $nexml_fac->create_bphylo_aln($aln,  $taxa_o);
		
		$phylo_matrix_o->set_taxa($taxa_o) if defined $taxa_o;
		$matrices->insert($phylo_matrix_o);	
	}
	
	my $seq_matrix_o;
	my $datum;
	#convert sequences to Bio::Phylo objects
	foreach my $seq (@$seqs)
	{
		$taxa_o = undef;
		#check if this Bio::Phylo::Taxa obj has already been created
		if (defined $taxa_hash{ $seq->{_Nexml_ID} }) {
			$taxa_o = $taxa_hash{$seq->{_Nexml_ID}};
		}
		else {
			($taxa_o) = $nexml_fac->create_bphylo_taxa($seq);
			$taxa_hash{$seq->{_Nexml_ID}} = $taxa_o;
		}
		$datum = $nexml_fac->create_bphylo_seq($seq, $taxa_o);
		#check if this Bio::Phylo::Matrices::Matrix obj has already been created
		if (defined $seq_matrices{ $seq->{_Nexml_matrix_ID} }) {
			$seq_matrix_o = $seq_matrices{$seq->{_Nexml_matrix_ID}};
			my $taxon_name = $datum->get_taxon()->get_name();
			$datum->unset_taxon();
			$seq_matrix_o->insert($datum);
			$datum->set_taxon($seq_matrix_o->get_taxa()->get_by_name($taxon_name));
		}
		else {
			$seq_matrix_o = Bio::Phylo::Factory->create_matrix('-type' => $datum->moltype);
			$seq_matrices{$seq->{_Nexml_matrix_ID}} = $seq_matrix_o;
			$seq_matrix_o->set_taxa($taxa_o) if defined $taxa_o;
			$seq_matrix_o->insert($datum);
			
			#get matrix label
			my $feat = ($seq->get_SeqFeatures())[0];
			my $matrix_label = ($feat->get_tag_values('matrix_label'))[0] if $feat->has_tag('id');
			$seq_matrix_o->set_name($matrix_label);
			
			$matrices->insert($seq_matrix_o);
		}
	}
	
	#Add matrices and forest objects to project object which represents a complete nexml document
	if($forest->first) {
		$proj_doc->insert($forest);
	}
	while(my $curr_matrix = $matrices->next) {
		$proj_doc->insert($curr_matrix);
	}
	
	#write nexml document to stream
	my $ret = $self->_print($proj_doc->to_xml(-compact=>1));
	$self->flush;
	return($ret);
}

=head2 extract_seqs

 Title   : extract_seqs
 Usage   : $nexmlIO->extract_seqs(-file => ">$outfile", -format => $format)
 Function: converts BioPerl seqs stored in the NexmlIO object into the provided 
 		   format and writes it to the provided file. Uses L<Bio::SeqIO> to do 
 		   the conversion and writing.
 Returns : none
 Args    : file to write to, format to be converted to

See L<Bio::Seq>, L<Bio::SeqIO>

=cut

sub extract_seqs {
	my $self = shift;
	unless ( $self->{'_parsed'} ) {
        $self->_parse;
    }
	
	my %params = @_;
	my $remove_spaces = 0;
	my $ret = 0;
	my ($format, $file) = @params{qw( -format -file)};
	
	for ($format) {
    /^fasta$/i && do {
        # this is ok, flag so that the nexmlid gets converted;
        $remove_spaces = 1;
        last;
    };
    # default
    do {
       $self->throw("Format '$format' not yet supported for extraction");
    };
}
	
	my $seqIO = Bio::SeqIO->new(-format => $format, -file => $file);
	my $seqs = $self->{_seqs};
	foreach my $seq (@$seqs) {
		if ($remove_spaces) {
			my $id = $seq->id;
			$id =~ s/ /_/;
			$seq->id($id);
		}
		$ret = $seqIO->write_seq($seq);
	}
	return $ret;
}

=head2 extract_alns

 Title   : extract_alns
 Usage   : $nexmlIO->extract_alns(-file => ">$outfile", -format => $format)
 Function: converts BioPerl alns stored in the NexmlIO object into the provided 
 		   format and writes it to the provided file. Uses L<Bio::AlignIO> to do 
 		   the conversion and writing.
 Returns : none
 Args    : file to write to, format to be converted to

See L<Bio::SimpleAlign>, L<Bio::AlignIO>

=cut

sub extract_alns {
	my $self = shift;
	unless ( $self->{'_parsed'} ) {
        $self->_parse;
    }
	
	my $ret = 0;
	my %params = @_;
	my ($format, $file) = @params{qw( -format -file)};
	
	my $alignIO = Bio::AlignIO->new(-format => $format, -file => $file);
	my $alns = $self->{_alns};
	foreach my $aln (@$alns) {
		$ret = $alignIO->write_aln($aln);
	}
	return $ret;
}

=head2 extract_trees

 Title   : extract_trees
 Usage   : $nexmlIO->extract_trees(-file => ">$outfile", -format => $format)
 Function: converts BioPerl trees stored in the NexmlIO object into the provided 
 		   format and writes it to the provided file. Uses L<Bio::TreeIO> to do 
 		   the conversion and writing.
 Returns : none
 Args    : file to write to, format to be converted to

See L<Bio::Tree::Tree>, L<Bio::TreeIO>

=cut

sub extract_trees {
	my $self = shift;
	unless ( $self->{'_parsed'} ) {
        $self->_parse;
    }
	
	my $ret = 0;
	my %params = @_;
	my ($format, $file) = @params{qw( -format -file)};
	
	my $treeIO = Bio::TreeIO->new(-format => $format, -file => $file);
	my $trees = $self->{_trees};
	foreach my $tree (@$trees) {
		$treeIO->write_tree($tree);
		$ret = 1;
	}
	return $ret;
}

1;