view release on metacpan or  search on metacpan

Bio/Nexml/Factory.pm  view on Meta::CPAN

 Title   : create_bphylo_node
 Usage   : my $bphylo_node = $factory->create_bphylo_node($bperl_node);
 Function: Converts a L<Bio::Tree::Node> object into Bio::Phylo::Forest::Node object
 Returns : a Bio::Phylo::Forest::Node object
 Args    : L<Bio::Tree::Node> object

=cut

sub create_bphylo_node {
    my ($bpnode) = @_;
        my $node = Bio::Phylo::Forest::Node->new();
        
        #mostly ripped from Bio::Phylo::Forest::Node->new_from_bioperl()
        # copy name
        my $name = $bpnode->id;
        $node->set_name( $name ) if defined $name;
        
        # copy branch length
        my $branch_length = $bpnode->branch_length;
        $node->set_branch_length( $branch_length ) if defined $branch_length;
        
        # copy description
        my $desc = $bpnode->description;
        $node->set_desc( $desc ) if defined $desc;
        
        # copy bootstrap
        my $bootstrap = $bpnode->bootstrap;
        $node->set_score( $bootstrap ) if defined $bootstrap and looks_like_number $bootstrap;
        
        # copy other tags
        for my $tag ( $bpnode->get_all_tags ) {
            my @values = $bpnode->get_tag_values( $tag );
            $node->set_generic( $tag => \@values );
        }
        return $node;
    }
    

=head2 create_bphylo_aln

 Title   : create_bphylo_aln
 Usage   : my $bphylo_aln = $factory->create_bphylo_aln($bperl_aln);
 Function: Converts a L<Bio::SimpleAlign> object into Bio::Phylo::Matrices::Matrix object
 Returns : a Bio::Phylo::Matrices::Matrix object
 Args    : Bio::SimpleAlign object

=cut

sub create_bphylo_aln {
    
    my ($self, $aln, $taxa, @args) = @_;
    
    #most of the code below ripped from Bio::Phylo::Matrices::Matrix::new_from_bioperl()
    if ( $aln->isa('Bio::Align::AlignI') ) {
            $aln->unmatch;
            $aln->map_chars('\.','-');
            my @seqs = $aln->each_seq;
            my ( $type, $missing, $gap, $matchchar ); 
            if ( $seqs[0] ) {
                $type = $seqs[0]->alphabet || $seqs[0]->_guess_alphabet || 'dna';
            }
            else {
                $type = 'dna';
            }
            
            my $matrix = $fac->create_matrix( 
                '-type' => $type,
                '-special_symbols' => {
                    '-missing'   => $aln->missing_char || '?',
                    '-matchchar' => $aln->match_char   || '.',
                    '-gap'       => $aln->gap_char     || '-',                  
                },
                @args 
            );          
            # XXX create raw getter/setter pairs for annotation, accession, consensus_meta source
            for my $field ( qw(description accession id annotation consensus_meta score source) ) {
                $matrix->$field( $aln->$field );
            }           
            my $to = $matrix->get_type_object;  
            my @feats = $aln->get_all_SeqFeatures();
            
            for my $seq ( @seqs ) {
                #create datum linked to taxa
                my $datum = create_bphylo_datum($seq, $taxa, \@feats, '-type_object' => $to);                                       
                $matrix->insert($datum);
            }  
            return $matrix;
        }
        else {
            $self->throw('Not a bioperl alignment!');
        }
}



=head2 create_bphylo_seq

 Title   : create_bphylo_seq
 Usage   : my $bphylo_seq = $factory->create_bphylo_seq($bperl_seq);
 Function: Converts a L<Bio::Seq> object into Bio::Phylo::Matrices::Matrix object
 Returns : a Bio::Phylo::Matrices::Matrix object
 Args    : Bio::Seq object

=cut

sub create_bphylo_seq {
    my ($self, $seq, $taxa, @args) = @_;
    my $type    = $seq->alphabet || $seq->_guess_alphabet || 'dna';
    $type = uc($type);
    
    my $dat = create_bphylo_datum($seq, $taxa, '-type' => $type);  
        
    # copy seq string
    my $seqstring = $seq->seq;
    if ( $seqstring and $seqstring =~ /\S/ ) {
        eval { $dat->set_char( $seqstring ) };
        if ( $@ and UNIVERSAL::isa($@,'Bio::Phylo::Util::Exceptions::InvalidData') ) {
            $self->throw("\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n");
        }
    }              
        
    # copy name
    my $name = $seq->display_id;
    #$dat->set_name( $name ) if defined $name;
                
    # copy desc
    my $desc = $seq->desc;   
    $dat->set_desc( $desc ) if defined $desc; 
    
    #get features from SeqFeatureI
    for my $field ( qw(start end strand) ) {
        $dat->$field( $seq->$field ) if $seq->can($field);
    }
    return $dat;
}

=head2 create_bphylo_taxa

 Title   : create_bphylo_seq
 Usage   : my $taxa = $factory->create_bphylo_taxa($bperl_obj);
 Function: creates a taxa object from the data attached to a bioperl object
 Returns : a Bio::Phylo::Taxa object
 Args    : L<Bio::Seq> object, or L<Bio::SimpleAlign> object, or L<Bio::Tree::Tree> object

=cut

sub create_bphylo_taxa {
    my $self = shift @_;
    my ($obj) = @_;
    
    #check if tree or aln object
    if ( UNIVERSAL::isa( $obj, 'Bio::Align::AlignI' ) || UNIVERSAL::isa( $obj, 'Bio::Seq')) {
        return $self->_create_bphylo_matrix_taxa(@_);
    }
    elsif ( UNIVERSAL::isa( $obj, 'Bio::Tree::TreeI' ) ) {
        return $self->_create_bphylo_tree_taxa(@_);
    }
}

sub _create_bphylo_tree_taxa {
    my ($self, $tree) = @_;
    
    my $taxa = $fac->create_taxa();
    my $taxon;
    
    #check if taxa exists
    unless ($tree->has_tag('taxa_id')) {
        return 0;

Bio/Nexml/Factory.pm  view on Meta::CPAN

    $taxa->set_xml_id(($tree->get_tag_values('taxa_id'))[0]);
    $taxa->set_name(($tree->get_tag_values('taxa_label'))[0]);
    
    foreach my $taxon_name ($tree->get_tag_values('taxon')) {
        
        $taxon = $fac->create_taxon(-name => $taxon_name);
        $taxa->insert($taxon);
    }
    return $taxa;
}

sub _create_bphylo_matrix_taxa {
    my ($self, $aln) = @_;
    
    my $taxa = $fac->create_taxa();
    my $taxon;
    my @feats = $aln->get_all_SeqFeatures();
            
    foreach my $feat (@feats) {
    if (my $taxa_id = ($feat->get_tag_values('taxa_id'))[0]) {
        my $taxa_label = ($feat->get_tag_values('taxa_label'))[0];
    
        $taxa->set_name($taxa_label) if defined $taxa_label;
        $taxa->set_xml_id($taxa_id) if defined $taxa_label;
        my @taxa_bp = $feat->get_tag_values('taxon');
        foreach my $taxon_name (@taxa_bp) {
            $taxon = $fac->create_taxon(-name => $taxon_name);
            $taxa->insert($taxon);
        }
        last;
        }
    }
    return $taxa
}

=head2 create_bphylo_datum

 Title   : create_bphylo_datum
 Usage   : my $bphylo_datum = $factory->create_bphylo_datum($bperl_datum);
 Function: Converts a L<Bio::Seq> object into Bio::Phylo::Matrices::datum object
 Returns : a Bio::Phylo::Matrices::datum object
 Args    : Bio::Seq object, Bio::Phylo::Taxa object, 
           [optional] arrayref to SeqFeatures,
           [optional] key => value pairs to pass to Bio::Phylo constructor

=cut

sub create_bphylo_datum {
    #mostly ripped from Bio::Phylo::Matrices::Datum::new_from_bioperl()
    my ( $seq, $taxa, @args ) = @_;
    my $class = 'Bio::Phylo::Matrices::Datum';
    my $feats;
    # want $seq type-check here? Allowable: is-a Bio::PrimarySeq, 
        #  Bio::LocatableSeq /maj
    if (@args % 2) { # odd
        $feats = shift @args;
        unless (ref($feats) eq 'ARRAY') {
        Bio::Root::Root->throw("Third argument must be array of SeqFeatures");
        }
    }
        my $type = $seq->alphabet || $seq->_guess_alphabet || 'dna';
        my $self = $class->new( '-type' => $type, @args );
        # copy seq string
        my $seqstring = $seq->seq;
        if ( $seqstring and $seqstring =~ /\S/ ) {
            eval { $self->set_char( $seqstring ) };
            if ( $@ and UNIVERSAL::isa($@,'Bio::Phylo::Util::Exceptions::InvalidData') ) {
                $self->throw("\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n");
            }
        }      
        
        # copy name
        my $name = $seq->display_id;
        $self->set_name( $name ) if defined $name;
        my $taxon;
    my @feats = (defined $feats ? @$feats : $seq->get_all_SeqFeatures);
        # convert taxa
        foreach my $feat (@feats)
        {
            #get sequence id associated with taxa to compare
            my $taxa_id = ($feat->get_tag_values('id'))[0] if $feat->has_tag('id');
            if ($taxa_id && $name eq $taxa_id)
            {
                my $taxon_name;
                if($feat->has_tag('my_taxon')) {
                    $taxon_name = ($feat->get_tag_values('my_taxon'))[0]
                }
                else {
                    $taxon_name = ($feat->get_tag_values('taxon'))[0];
                }
                $self->set_taxon($taxa->get_by_name($taxon_name));
            }
        }
          
        # copy desc
        my $desc = $seq->desc;   
        $self->set_desc( $desc ) if defined $desc;   

    # only Bio::LocatableSeq objs have these fields...
        for my $field ( qw(start end strand) ) {
        $self->$field( $seq->$field ) if $seq->can($field);
        }   
        return $self;
}

=head2 CREATOR

=cut

=head1 bioperl_create

 Title   : bioperl_create
 Usage   : $bioperl_obj = $fac->bioperl_create($obj_type, $biophylo_proj);
 Function: Create a specified bioperl object using a Bio::Phylo project
 Args    : scalar string ('aln', 'tree', 'seq') type designator
           Bio::Phylo::Project object
 Returns : Appropriate BioPerl object

=cut

sub bioperl_create {