File Coverage

Bio/AlignIO/Handler/GenericAlignHandler.pm

Criterion	Covered	Total	%
statement	185	211	87.6
branch	67	120	55.8
condition	19	38	50.0
subroutine	29	32	90.6
pod	11	11	100.0
total	311	412	75.4

# Let the code begin...

package Bio::AlignIO::Handler::GenericAlignHandler;

use strict;
use warnings;

use Bio::Annotation::Collection;
use Bio::Annotation::Comment;
use Bio::Annotation::SimpleValue;
use Bio::Annotation::Target;
use Bio::Annotation::DBLink;
use Bio::Annotation::Reference;
use Bio::SimpleAlign;
use Data::Dumper;

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

# only stockholm is defined for now...
my %HANDLERS = (
    # stockholm has sequence and alignment specific annotation; this
    'stockholm'   => {
        'CONSENSUS_META'    => \&_generic_consensus_meta,
        'SEQUENCE'          => \&_generic_metaseq,
        'NAMED_META'        => \&_generic_metaseq,
        'ACCESSION'         => \&_generic_store,
        'ALPHABET'          => \&_generic_store,
        'ID'                => \&_generic_store,
        'DESCRIPTION'       => \&_generic_store,
        'REFERENCE'         => \&_generic_reference,
        'DBLINK'            => \&_stockholm_target,
        'DATABASE_COMMENT'  => \&_generic_comment,
        'ALIGNMENT_COMMENT' => \&_generic_comment,
        '_DEFAULT_'         => \&_generic_simplevalue
        },
    );

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    my ($format, $verbose) = $self->_rearrange([qw(FORMAT VERBOSE)], @args);
    $self->throw("Must define alignment record format") if !$format;
    $verbose   && $self->verbose($verbose);
    $self->format($format);
    $self->handler_methods();
    # if we intend at a later point we can add a Builder
    #$builder  &&  $self->alignbuilder($builder);
    return $self;
}

sub handler_methods {
    my $self = shift;
    if (!($self->{'handlers'})) {
        $self->throw("No handlers defined for alignment format ",$self->format)
            unless exists $HANDLERS{$self->format};
        $self->{'handlers'} = $HANDLERS{$self->format};
    }
    return ($self->{'handlers'});
}

sub data_handler {
    my ($self, $data) = @_;
    my $nm = $data->{NAME} || $self->throw("No name tag defined!");
    # this should handle data on the fly w/o caching; any caching should be
    # done in the driver!
    my $method = (exists $self->{'handlers'}->{$nm}) ? ($self->{'handlers'}->{$nm}) :
                (exists $self->{'handlers'}->{'_DEFAULT_'}) ? ($self->{'handlers'}->{'_DEFAULT_'}) :
                undef;
    if (!$method) {
        $self->debug("No handler defined for $nm\n");
        return;
    };
    $self->$method($data);
}

sub reset_parameters {
    my $self = shift;
    $self->{'_params'} = undef;
    $self->{'_nse_cache'} = undef;
    $self->{'_features'} = undef;
}

sub format {
    my $self = shift;
    if (@_) {
        my $format = lc shift;
        $self->throw("Format $format not supported") unless exists $HANDLERS{$format};
        $self->{'_alignformat'} = $format;
    };
    return $self->{'_alignformat'};
}

sub get_params {
    my ($self, @ids) = @_;
    my $data;
    if (scalar(@ids)) {
        for my $id (@ids) {
            if (!index($id, '-')==0) {
                $id = '-'.$id ;
            }
            $data->{$id} = $self->{'_params'}->{$id} if (exists $self->{'_params'}->{$id});
        }
        $data ||= {};
    } else {
        $data = $self->{'_params'};
    }
    return $data;
}

sub set_params {
    shift->throw('Not implemented yet!');
}

sub build_alignment {
    my $self = shift;
    my %init;
    $self->process_seqs;
    my $param = $self->get_params;
    if (defined $param->{-seqs}) {
        return Bio::SimpleAlign->new(%$param, -source => $self->format);
    }
    return;
}

sub annotation_collection {
    my ($self, $coll) = @_;
    if ($coll) {
        $self->throw("Must have Bio::AnnotationCollectionI ".
                     "when explicitly setting annotation_collection()")
            unless (ref($coll) && $coll->isa('Bio::AnnotationCollectionI'));
        $self->{'_params'}->{'-annotation'} = $coll;
    } elsif (!exists($self->{'_params'}->{'-annotation'})) {
        $self->{'_params'}->{'-annotation'} = Bio::Annotation::Collection->new()
    }
    return $self->{'_params'}->{'-annotation'};
}

sub seq_annotation_collection {
    my ($self, $coll) = @_;
    if ($coll) {
        $self->throw("Must have Bio::AnnotationCollectionI ".
                     "when explicitly setting seq_annotation_collection()")
            unless (ref($coll) && $coll->isa('Bio::AnnotationCollectionI'));
        $self->{'_params'}->{'-seq_annotation'} = $coll;
    } elsif (!exists($self->{'_params'}->{'-seq_annotation'})) {
        $self->{'_params'}->{'-seq_annotation'} = Bio::Annotation::Collection->new()
    }
    return $self->{'_params'}->{'-seq_annotation'};
}

sub process_seqs {
    my $self = shift;

    my $data = $self->get_params(qw(-seqs -seq_class -consensus_meta));
    my $class = $data->{-seq_class} || 'Bio::LocatableSeq';
    # cache classes loaded already
    if (!exists($self->{'_loaded_modules'}->{$class})) {
        $self->_load_module($class);
        $self->{'_loaded_modules'}->{$class}++;
    }
    # process any meta sequence data
    if ( $data->{-consensus_meta} && !UNIVERSAL::isa($data->{-consensus_meta},'Bio::Seq::Meta')) {
        my $ref = $data->{-consensus_meta};
        if (!exists($self->{'_loaded_modules'}->{'Bio::Seq::Meta'})) {
            $self->_load_module('Bio::Seq::Meta');
            $self->{'_loaded_modules'}->{'Bio::Seq::Meta'}++;
        }
        my $ms = Bio::Seq::Meta->new();
        for my $tag (sort keys %{$ref}) {
            $ms->named_meta($tag, $ref->{$tag});
        }
        $self->{'_params'}->{'-consensus_meta'} = $ms;
    }
    # this should always be an array ref!
    for my $seq (@{$data->{-seqs}}) {
        next if (UNIVERSAL::isa($seq,'Bio::LocatableI'));
        # process anything else
        $self->_from_nse($seq) if $seq->{NSE};
        if (UNIVERSAL::isa($seq,'HASH')) {
            my %param;
            for my $p (keys %$seq) {
                $param{'-'.lc $p} = $seq->{$p} if exists $seq->{$p};
            }
            my $ls = $class->new(%param);
            # a little switcheroo to attach the sequence
            # (though using it to get seq() doesn't work correctly yet!)
            if (defined $seq->{NSE} &&
                exists $self->{'_features'} &&
                exists $self->{'_features'}->{ $seq->{NSE} }) {
                for my $feat (@{ $self->{'_features'}->{ $seq->{NSE} } }) {
                    push @{ $self->{'_params'}->{'-features'} }, $feat;
                    $feat->attach_seq($ls);
                }
            }
            $seq = $ls;
        }
    }
}

####################### SEQUENCE HANDLERS #######################

# any sequence data for a Bio::Seq::Meta
sub _generic_metaseq {
    my ($self, $data) = @_;
    return unless $data;
    $self->throw("No alignment position passed") if !exists($data->{BLOCK_LINE});
    $self->throw("Alignment position must be an index greater than 0") if $data->{BLOCK_LINE} < 1;
    $self->{'_params'}->{'-seq_class'} = 'Bio::Seq::Meta';
    my $index = $data->{BLOCK_LINE} - 1;
    if (my $nse = $self->{'_params'}->{'-seqs'}->[$index]->{NSE}) {
        $self->throw("NSE in passed data doesn't match stored data in same position: $nse") unless $nse eq $data->{NSE};
    } else {
        $self->{'_params'}->{'-seqs'}->[$index]->{NSE} = $data->{NSE};
    }
    if ($data->{NAME} eq 'SEQUENCE') {
        $self->{'_params'}->{'-seqs'}->[$index]->{SEQ} .= $data->{DATA};
    } elsif ($data->{NAME} eq 'NAMED_META') {
        $self->{'_params'}->{'-seqs'}->[$index]->{NAMED_META}->{$data->{META_TAG}} .= $data->{DATA};
    }
}

sub _generic_consensus_meta {
    my ($self, $data) = @_;
    return unless $data;
    if ($data->{NAME} eq 'CONSENSUS_META') {
        $self->{'_params'}->{'-consensus_meta'}->{$data->{META_TAG}} .= $data->{DATA};
    }
}

# any sequence data for a Bio::LocatableSeq
sub _generic_locatableseq {
    my ($self, $data) = @_;
    return unless $data;
    $self->throw("No alignment position passed") if !exists($data->{BLOCK_LINE});
    $self->throw("Alignment position must be an index greater than 0") if $data->{BLOCK_LINE} < 1;
    my $index = $data->{BLOCK_LINE} - 1;
    if (my $nse = $self->{'_params'}->{'-seqs'}->[$index]->{NSE}) {
        $self->throw("NSE in passed data doesn't match stored data in same position: $nse") if $nse ne $data->{NSE};
    } else {
        $self->{'_params'}->{'-seqs'}->[$index]->{NSE} = $data->{NSE};
    }
    if ($data->{NAME} eq 'SEQUENCE') {
        $self->{'_params'}->{'-seqs'}->[$index]->{SEQ} .= $data->{DATA};
    }
}

####################### RAW DATA HANDLERS #######################

# store by data name (ACCESSION, ID, etc), which can be mapped to the
# appropriate alignment or sequence parameter
sub _generic_store {
    my ($self, $data) = @_;
    return unless $data;
    if ($data->{ALIGNMENT}) {
        $self->{'_params'}->{'-'.lc $data->{NAME}} = $data->{DATA};
    } else {
        $self->{'_params'}->{'-seq_'.lc $data->{NAME}}->{$data->{NSE}} = $data->{DATA}
    }
}

sub _generic_reference {
    my ($self, $data) = @_;
    my $ref = Bio::Annotation::Reference->new(-title => $data->{TITLE},
                                              -authors => $data->{AUTHORS},
                                              -pubmed => $data->{PUBMED},
                                              -location => $data->{JOURNAL},
                                              -tagname  => lc $data->{NAME});
    $self->annotation_collection->add_Annotation($ref);
}

sub _generic_simplevalue {
    my ($self, $data) = @_;
    my $sv = Bio::Annotation::SimpleValue->new(-value => $data->{DATA},
                                            -tagname  => lc $data->{NAME});
    $self->annotation_collection->add_Annotation($sv);
}

sub _generic_comment {
    my ($self, $data) = @_;
    my $comment = Bio::Annotation::Comment->new(-type => lc $data->{NAME},
                                                -text => $data->{DATA},
                                                -tagname  => lc $data->{NAME});
    $self->annotation_collection->add_Annotation($comment);
}

# Some DBLinks in Stockholm format are unique, so a unique handler for them
sub _stockholm_target {
    my ($self, $data) = @_;
    # process database info
    $self->_from_stk_dblink($data);
    my $comment;
    # Bio::Annotation::Target is now a DBLink, but has additional (RangeI)
    # capabilities (for PDB data)
    my $dblink = Bio::Annotation::Target->new(
        -database => $data->{DBLINK_DB},
        -primary_id => $data->{DBLINK_ACC},
        -optional_id => $data->{DBLINK_OPT},
        -start => $data->{DBLINK_START},
        -end => $data->{DBLINK_END},
        -strand => $data->{DBLINK_STRAND},
        -comment => $comment,
        -tagname => 'dblink',
    );
    if ($data->{ALIGNMENT}) {
        # Alignment-specific DBLinks
        $self->annotation_collection->add_Annotation($dblink);
    } else {
        # Sequence-specific DBLinks
        # These should come with identifying information of some sort
        # (ID/START/END/STRAND).  Make into a SeqFeature (SimpleAlign is
        # FeatureHolderI) spanning the length acc. to the NSE. Add the DBLink as
        # Annotation specific to that SeqFeature, store in an internal hash by
        # NSE so we can tie the LocatableSeq to the proper Features
        $self->_from_nse($data) if $data->{NSE};
        $self->throw("Must supply an sequence DISPLAY_ID or NSE for sequence-related
            DBLinks") unless $data->{ACCESSION_NUMBER} || $data->{DISPLAY_ID};
        my $sf = Bio::SeqFeature::Generic->new(-seq_id => $data->{DISPLAY_ID},
                                               -accession_number => $data->{ACCESSION_NUMBER},
                                               -start => $data->{START},
                                               -end => $data->{END},
                                               -strand => $data->{STRAND}
                                               );
        $sf->annotation->add_Annotation($dblink);
        # index by NSE
        push @{ $self->{'_features'}->{ $data->{NSE} } }, $sf;
        #$self->seq_annotation_collection->add_Annotation($dblink);
    }
}

####################### HELPER METHODS #######################

# returns ACCESSION VERSION START END STRAND ALPHABET
# cached for multiple lookups, should reset in between uses
sub _from_nse {
    my ($self, $data) = @_;
    return unless my $nse = $data->{NSE};
    $data->{ALPHABET} =  $self->get_params('-alphabet')->{'-alphabet'} || 'protein';
    # grab any accessions if present, switch out with ACCESSION from NSE
    # (move that to primary_id)
    my $new_acc;
    if (exists $self->{'_params'}->{'-seq_accession'}) {
        $new_acc = $self->{'_params'}->{'-seq_accession'}->{$data->{NSE}};
    }
    if ($nse =~ m{(\S+?)(?:\.(\d+))?/(\d+)-(\d+)}xmso) {
        my $strand = $data->{ALPHABET} eq 'dna' || $data->{ALPHABET} eq 'rna' ? 1 : undef;
        my ($start, $end) = ($3, $4);
        if ($start > $end) {
            ($start, $end, $strand) = ($end, $start, -1);
        }
        $data->{ACCESSION_NUMBER} = $new_acc || $1;
        $data->{DISPLAY_ID} = $1;
        $data->{VERSION} = $2;
        $data->{START} = $start;
        $data->{END} = $end;
        $data->{STRAND} = $strand;
    } else {
        # we can parse for version here if needed
        $data->{DISPLAY_ID} = $data->{NSE};
    }
}

# this will probably be split up into subhandlers based on Record/DB
sub _from_stk_dblink {
    my ($self, $data) = @_;
    return unless my $raw = $data->{DATA};
    my @rawdata = split(m{\s*;\s*}, $raw);
    my %dblink_data;
    if ($rawdata[0] eq 'PDB') {
        # fix for older Stockholm PDB range format
        if (scalar(@rawdata) == 3 && $rawdata[2] =~ m{-}) {
            @rawdata[2,3] = split('-',$rawdata[2],2);
        }
        $self->throw("Not standard PDB form: ".$data->{DATA}) if scalar(@rawdata) != 4;
        my ($main, $chain) = split(m{\s+}, $rawdata[1]);
        %dblink_data = (
            DBLINK_DB => $rawdata[0],
            DBLINK_ACC => $main,
            DBLINK_OPT => $chain || '',
            DBLINK_START => $rawdata[2],
            DBLINK_END => $rawdata[3]
        );
    } elsif ($rawdata[0] eq 'SCOP') {
        $self->throw("Not standard SCOP form: ".$data->{DATA}) if scalar(@rawdata) != 3;
        %dblink_data = (
            DBLINK_DB => $rawdata[0],
            DBLINK_ACC => $rawdata[1],
            DBLINK_OPT => $rawdata[2],
        );
    } else {
        $self->warn("Some data missed: ".$data->{DATA}) if scalar(@rawdata) > 2;
        %dblink_data = (
            DBLINK_DB => $rawdata[0],
            DBLINK_ACC => $rawdata[1],
        );
    }
    while (my ($k, $v) = each %dblink_data) {
        $data->{$k} = $v if $v;
    }
}

1;

__END__