Bio::AlignIO::Handler::GenericAlignHandler - Bio::HandlerI-based

  # MyHandler is a GenericAlignHandler object.
  # inside a parser (driver) constructor....

  $self->alignhandler($handler || MyHandler->new(-format => 'stockholm'));

  # in next_aln() in driver...

  $hobj = $self->alignhandler();

  # roll data up into hashref chunks, pass off into Handler for processing...

  $hobj->data_handler($data);

  # or retrieve Handler methods and pass data directly to Handler methods...

  my $hmeth = $hobj->handler_methods;

  if ($hmeth->{ $data->{NAME} }) {
      my $mth = $hmeth->{ $data->{NAME} };
      $hobj->$mth($data);
  }

  $VAR1 = {
            'NAME' => 'REFERENCE',
            'DATA' => '1  (bases 1 to 10001)'
            'AUTHORS' => 'International Human Genome Sequencing Consortium.'
            'TITLE' => 'The DNA sequence of Homo sapiens'
            'JOURNAL' => 'Unpublished (2003)'
            'ALIGNMENT' => 1,
          };

  $VAR1 = {
            'NAME' => 'SEQUENCE', 
            'BLOCK_LINE' => 0,
            'NSE' => 'Q7WNI7_BORBR/113-292',
            'ALPHABET' => 'protein',
            'DATA' => 'VALILGVYRRL...CYVNREM..RAG....QW',
            'ALIGNMENT' => 0            
          };

  $VAR1 = {
            'NAME' => 'NAMED_META',
            'BLOCK_LINE' => 0,
            'NSE' => 'Q7WNI7_BORBR/113-292',
            'META_KEY' => 'pAS',
            'DATA' => '................................',
            'ALIGNMENT' => 0
          };

  $VAR1 = {
            'NAME' => 'CONSENSUS',
            'DATA' => 'VALILGVYRRL...CYVNREM..RAG....QW',
            'ALIGNMENT' => 1
          };

  $VAR1 = {
            'NAME' => 'CONSENSUS_META',
            'META_KEY' => 'pAS',
            'DATA' => '................................',
            'ALIGNMENT' => 1
          };

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

  https://redmine.open-bio.org/projects/bioperl/

 Title   :  new
 Usage   :  
 Function:  
 Returns :  
 Args    :  -format    Sequence format to be mapped for handler methods
            -builder   Bio::Seq::SeqBuilder object (normally defined in
                       SequenceStreamI object implementation constructor)
 Throws  :  On undefined '-format' sequence format parameter
 Note    :  Still under heavy development

 Title   :  handler_methods
 Usage   :  $handler->handler_methods('GenBank')
            %handlers = $handler->handler_methods();
 Function:  Retrieve the handler methods used for the current format() in
            the handler.  This assumes the handler methods are already
            described in the HandlerI-implementing class.
 Returns :  a hash reference with the data type handled and the code ref
            associated with it.
 Args    :  [optional] String representing the sequence format.  If set here
            this will also set sequence_format()
 Throws  :  On unimplemented sequence format in %HANDLERS

 Title   :  data_handler
 Usage   :  $handler->data_handler($data)
 Function:  Centralized method which accepts all data chunks, then distributes
            to the appropriate methods for processing based on the chunk name
            from within the HandlerBaseI object.

            One can also use 
 Returns :  None
 Args    :  an hash ref containing a data chunk.  

 Title   :  reset_parameters
 Usage   :  $handler->reset_parameters()
 Function:  Resets the internal cache of data (normally object parameters for
            a builder or factory)
 Returns :  None
 Args    :  None

 Title   :  format
 Usage   :  $handler->format('GenBank')
 Function:  Get/Set the format for the report/record being parsed. This can be
            used to set handlers in classes which are capable of processing
            similar data chunks from multiple driver modules.
 Returns :  String with the sequence format
 Args    :  [optional] String with the sequence format
 Note    :  The format may be used to set the handlers (as in the
            current GenericRichSeqHandler implementation)

 Title   :  get_params
 Usage   :  $handler->get_params('-species')
 Function:  Convenience method used to retrieve the specified
            parameters from the internal parameter cache
 Returns :  Hash ref containing parameters requested and data as
            key-value pairs.  Note that some parameter values may be 
            objects, arrays, etc.
 Args    :  List (array) representing the parameters requested

 Title   :  set_params
 Usage   :  $handler->set_param({'-seqs' => $seqs})
 Function:  Convenience method used to set specific parameters
 Returns :  None
 Args    :  Hash ref containing the data to be passed as key-value pairs

 Title   :  build_alignment
 Usage   :  
 Function:  
 Returns :  a Bio::SimpleAlign
 Args    :
 Throws  :
 Note    :  This may be replaced by a Builder object at some point 

 Title   :  annotation_collection
 Usage   :  
 Function:  
 Returns :  
 Args    :
 Throws  :
 Note    :  

 Title   :  seq_annotation_collection
 Usage   :  
 Function:  
 Returns :  
 Args    :
 Throws  :
 Note    :  

 Title   :  process_seqs
 Usage   :  $handler->process_seqs;
 Function:  checks internal sequences to ensure they are converted over
            to the proper Bio::AlignI-compatible sequence class
 Returns :  1 if successful
 Args    :  none

# 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);
    }
}

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__

# $Id: GenericAlignHandler.pm 14816 2008-08-21 16:00:12Z cjfields $
#
# BioPerl module for Bio::AlignIO::Handler::GenericAlignHandler
#
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
#
# Cared for by Chris Fields
#
# Copyright Chris Fields
#
# You may distribute this module under the same terms as perl itself
#
# POD documentation - main docs before the code
#
# Documentation after the __END__ marker