#
# BioPerl module for Bio::SeqIO::Handler::GenericRichSeqHandler
#
# 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
=head1 NAME
Bio::SeqIO::Handler::GenericRichSeqHandler - Bio::HandlerI-based
data handler for GenBank/EMBL/UniProt (and other) sequence data
=head1 SYNOPSIS
# MyHandler is a GenericRichSeqHandler object.
# inside a parser (driver) constructor....
$self->seq_handler($handler || MyHandler->new(-format => 'genbank'));
# in next_seq() in driver...
$hobj = $self->seqhandler();
# 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);
}
=head1 DESCRIPTION
This is an experimental implementation of a sequence-based HandlerBaseI parser
and may change over time. It is possible (nay, likely) that the way handler
methods are set up will change over development to allow more flexibility.
Release pumpkins, please do not add this to a release until the API has settled.
It is also likely that write_seq() will not work properly for some data.
Standard Developer caveats:
Do not use for production purposes.
Not responsible for destroying (your data|computer|world).
Do not stare directly at GenericRichSeqHandler.
If GenericRichSeqHandler glows, back slowly away and call for help.
Consider yourself warned!
This class acts as a demonstration on how to handle similar data chunks derived
from Bio::SeqIO::gbdriver, Bio::SeqIO::embldriver, and Bio::SeqIO::swissdriver
using similar (or the same) handler methods.
The modules currently pass all previous tests in t/genbank.t, t/embl.t, and
t/swiss.t yet all use the same handler methods (the collected tests for handlers
can be found in t/Handler.t). Some tweaking of the methods themselves is
probably in order over the long run to ensure that data is consistently handled
for each parser. Round-trip tests are probably in order here...
Though a Bio::Seq::SeqBuilder is employed for building sequence objects no
bypassing of data based on builder slots has been implemented (yet); this is
planned in the near future.
As a reminder: this is the current Annotation data chunk (via Data::Dumper):
$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)'
};
...
This is the current SeqFeature data chunk (again via Data::Dumper):
$VAR1 = {
'mol_type' => 'genomic DNA',
'LOCATION' => '<1..>10001',
'NAME' => 'FEATURES',
'FEATURE_KEY' => 'source',
'note' => 'Accession AL451081 sequenced by The Sanger Centre',
'db_xref' => 'taxon:9606',
'clone' => 'RP11-302I18',
'organism' => 'Homo sapiens'
};
=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://redmine.open-bio.org/projects/bioperl/
=head1 AUTHOR - Chris Fields
Email cjfields at bioperl dot org
=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::SeqIO::Handler::GenericRichSeqHandler;
use strict;
use warnings;
use Bio::SeqIO::FTHelper;
use Bio::Annotation::Collection;
use Bio::Annotation::DBLink;
use Bio::Annotation::Comment;
use Bio::Annotation::Reference;
use Bio::Annotation::Collection;
use Bio::Annotation::SimpleValue;
use Bio::Annotation::TagTree;
use Bio::SeqFeature::Generic;
use Bio::Species;
use Bio::Taxon;
use Bio::DB::Taxonomy;
use Bio::Factory::FTLocationFactory;
use Data::Dumper;
use base qw(Bio::Root::Root Bio::HandlerBaseI);
my %HANDLERS = (
'genbank' => {
'LOCUS' => \&_genbank_locus,
'DEFINITION' => \&_generic_description,
'ACCESSION' => \&_generic_accession,
'VERSION' => \&_generic_version,
'KEYWORDS' => \&_generic_keywords,
'DBSOURCE' => \&_genbank_dbsource,
'DBLINK' => \&_genbank_dbsource,
'SOURCE' => \&_generic_species,
'REFERENCE' => \&_generic_reference,
'COMMENT' => \&_generic_comment,
'FEATURES' => \&_generic_seqfeatures,
'BASE' => \&noop, # this is generated from scratch
'ORIGIN' => \&_generic_seq,
# handles anything else (WGS, WGS_SCAFLD, CONTIG, PROJECT)
'_DEFAULT_' => \&_generic_simplevalue,
},
'embl' => {
'ID' => \&_embl_id,
'DT' => \&_embl_date,
'DR' => \&_generic_dbsource,
'SV' => \&_generic_version,
'RN' => \&_generic_reference,
'KW' => \&_generic_keywords,
'DE' => \&_generic_description,
'AC' => \&_generic_accession,
#'AH' => \&noop, # TPA data not dealt with yet...
#'AS' => \&noop,
'SQ' => \&_generic_seq,
'OS' => \&_generic_species,
'CC' => \&_generic_comment,
'FT' => \&_generic_seqfeatures,
# handles anything else (WGS, TPA, ANN...)
'_DEFAULT_' => \&_generic_simplevalue,
},
'swiss' => {
'ID' => \&_swiss_id,
'DT' => \&_swiss_date,
'GN' => \&_swiss_genename,
'DR' => \&_generic_dbsource,
'RN' => \&_generic_reference,
'KW' => \&_generic_keywords,
'DE' => \&_generic_description,
'AC' => \&_generic_accession,
'SQ' => \&_generic_seq,
'OS' => \&_generic_species,
'CC' => \&_generic_comment,
'FT' => \&_generic_seqfeatures,
# handles anything else, though I don't know what...
'_DEFAULT_' => \&_generic_simplevalue,
},
);
# can we do this generically? Seems like a lot of trouble...
my %DBSOURCE = map {$_ => 1} qw(
EchoBASE IntAct SWISS-2DPAGE ECO2DBASE ECOGENE TIGRFAMs
TIGR GO InterPro Pfam PROSITE SGD GermOnline
HSSP PhosSite Ensembl RGD AGD ArrayExpress KEGG
H-InvDB HGNC LinkHub PANTHER PRINTS SMART SMR
MGI MIM RZPD-ProtExp ProDom MEROPS TRANSFAC Reactome
UniGene GlycoSuiteDB PIRSF HSC-2DPAGE PHCI-2DPAGE
PMMA-2DPAGE Siena-2DPAGE Rat-heart-2DPAGE Aarhus/Ghent-2DPAGE
Biocyc MetaCyc Biocyc:Metacyc GenomeReviews FlyBase
TMHOBP COMPLUYEAST-2DPAGE OGP DictyBase HAMAP
PhotoList Gramene WormBase WormPep Genew ZFIN
PeroxiBase MaizeDB TAIR DrugBank REBASE HPA
swissprot GenBank GenPept REFSEQ embl PDB UniProtKB);
my %NOPROCESS = map {$_ => 1} qw(DBSOURCE ORGANISM FEATURES);
our %VALID_ALPHABET = (
'bp' => 'dna',
'aa' => 'protein',
'rc' => '' # rc = release candidate; file has no sequences
);
=head2 new
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
=cut
sub new {
my ($class, @args) = @_;
my $self = $class->SUPER::new(@args);
$self = {@args};
bless $self,$class;
my ($format, $builder) = $self->_rearrange([qw(FORMAT BUILDER)], @args);
$self->throw("Must define sequence record format") if !$format;
$self->format($format);
$self->handler_methods();
$builder && $self->seqbuilder($builder);
$self->location_factory();
return $self;
}
=head1 L<Bio::HandlerBaseI> implementing methods
=head2 handler_methods
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
=cut
sub handler_methods {
my $self = shift;
if (!($self->{'handlers'})) {
$self->throw("No handlers defined for seqformat ",$self->format)
unless exists $HANDLERS{$self->format};
$self->{'handlers'} = $HANDLERS{$self->format};
}
return ($self->{'handlers'});
}
=head2 data_handler
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.
=cut
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);
}
=head2 reset_parameters
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
=cut
sub reset_parameters {
my $self = shift;
$self->{'_params'} = undef;
}
=head2 format
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)
=cut
sub format {
my $self = shift;
return $self->{'_seqformat'} = lc shift if @_;
return $self->{'_seqformat'};
}
=head2 get_params
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
=cut
sub get_params {
my ($self, @ids) = @_;
my %data;
for my $id (@ids) {
if (!index($id, '-')==0) {
$id = '-'.$id ;
}
$data{$id} = $self->{'_params'}->{$id} if (exists $self->{'_params'}->{$id});
}
return \%data;
}
=head2 set_params
Title : set_params
Usage : $handler->set_param({'-species')
Function: Convenience method used to set specific parameters
Returns : None
Args : Hash ref containing the data to be passed as key-value pairs
=cut
sub set_params {
shift->throw('Not implemented yet!');
}
=head1 Methods unique to this implementation
=head2 seqbuilder
Title : seqbuilder
Usage :
Function:
Returns :
Args :
Throws :
Note :
=cut
sub seqbuilder {
my $self = shift;
return $self->{'_seqbuilder'} = shift if @_;
return $self->{'_seqbuilder'};
}
=head2 build_sequence
Title : build_sequence
Usage :
Function:
Returns :
Args :
Throws :
Note :
=cut
sub build_sequence {
my $self = shift;
my $builder = $self->seqbuilder();
my $seq;
if (defined($self->{'_params'})) {
$builder->add_slot_value(%{ $self->{'_params'} });
$seq = $builder->make_object();
$self->reset_parameters;
}
return $seq if $seq;
return 0;
}
=head2 location_factory
Title : location_factory
Usage :
Function:
Returns :
Args :
Throws :
Note :
=cut
sub location_factory {
my ($self, $factory) = @_;
if ($factory) {
$self->throw("Must have a Bio::Factory::LocationFactoryI when ".
"explicitly setting factory()") unless
(ref($factory) && $factory->isa('Bio::Factory::LocationFactoryI'));
$self->{'_locfactory'} = $factory;
} elsif (!defined($self->{'_locfactory'})) {
$self->{'_locfactory'} = Bio::Factory::FTLocationFactory->new()
}
return $self->{'_locfactory'};
}
=head2 annotation_collection
Title : annotation_collection
Usage :
Function:
Returns :
Args :
Throws :
Note :
=cut
sub annotation_collection {
my ($self, $coll) = @_;
if ($coll) {
$self->throw("Must have Bio::AnnotationCollectionI ".
"when explicitly setting 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'};
}
####################### SEQUENCE HANDLERS #######################
# any sequence data
sub _generic_seq {
my ($self, $data) = @_;
$self->{'_params'}->{'-seq'} = $data->{DATA};
}
####################### RAW DATA HANDLERS #######################
# GenBank LOCUS line
sub _genbank_locus {
my ($self, $data) = @_;
my (@tokens) = split m{\s+}, $data->{DATA};
my $display_id = shift @tokens;
$self->{'_params'}->{'-display_id'} = $display_id;
my $seqlength = shift @tokens;
if (exists $VALID_ALPHABET{$seqlength}) {
# moved one token too far. No locus name?
$self->warn("Bad LOCUS name? Changing [".$self->{'_params'}->{'-display_id'}.
"] to 'unknown' and length to ".$self->{'_params'}->{'-display_id'});
$self->{'_params'}->{'-length'} = $self->{'_params'}->{'-display_id'};
$self->{'_params'}->{'-display_id'} = 'unknown';
# add token back...
unshift @tokens, $seqlength;
} else {
$self->{'_params'}->{'-length'} = $seqlength;
}
my $alphabet = lc(shift @tokens);
$self->{'_params'}->{'-alphabet'} =
(exists $VALID_ALPHABET{$alphabet}) ? $VALID_ALPHABET{$alphabet} :
$self->warn("Unknown alphabet: $alphabet");
if (($self->{'_params'}->{'-alphabet'} eq 'dna') || (@tokens > 2)) {
$self->{'_params'}->{'-molecule'} = shift(@tokens);
my $circ = shift(@tokens);
if ($circ eq 'circular') {
$self->{'_params'}->{'-is_circular'} = 1;
$self->{'_params'}->{'-division'} = shift(@tokens);
} else {
# 'linear' or 'circular' may actually be omitted altogether
$self->{'_params'}->{'-division'} =
(CORE::length($circ) == 3 ) ? $circ : shift(@tokens);
}
} else {
$self->{'_params'}->{'-molecule'} = 'PRT' if($self->{'_params'}->{'-alphabet'} eq 'aa');
$self->{'_params'}->{'-division'} = shift(@tokens);
}
my $date = join(' ', @tokens);
# maybe use Date::Time for dates?
if($date && $date =~ s{\s*((\d{1,2})-(\w{3})-(\d{2,4})).*}{$1}) {
if( length($date) < 11 ) {
# improperly formatted date
# But we'll be nice and fix it for them
my ($d,$m,$y) = ($2,$3,$4);
if( length($d) == 1 ) {
$d = "0$d";
}
# guess the century here
if( length($y) == 2 ) {
if( $y > 60 ) { # arbitrarily guess that '60' means 1960
$y = "19$y";
} else {
$y = "20$y";
}
$self->warn("Date was malformed, guessing the century for $date to be $y\n");
}
$self->{'_params'}->{'-dates'} = [join('-',$d,$m,$y)];
} else {
$self->{'_params'}->{'-dates'} = [$date];
}
}
}
# EMBL ID line
sub _embl_id {
my ($self, $data) = @_;
my $alphabet;
my ($name, $sv, $topology, $mol, $div);
my $line = $data->{DATA};
#$self->debug("$line\n");
my ($idtype) = $line =~ tr/;/;/;
if ( $idtype == 6) { # New style headers contain exactly six semicolons.
# New style header (EMBL Release >= 87, after June 2006)
my $topology;
my $sv;
# ID DQ299383; SV 1; linear; mRNA; STD; MAM; 431 BP.
# This regexp comes from the new2old.pl conversion script, from EBI
if ($line =~ m/^(\w+);\s+SV (\d+); (\w+); ([^;]+); (\w{3}); (\w{3}); (\d+) \w{2}\./) {
($name, $sv, $topology, $mol, $div) = ($1, $2, $3, $4, $6);
} else {
$self->throw("Unrecognized EMBL ID line:[$line]");
}
if (defined($sv)) {
$self->{'_params'}->{'-seq_version'} = $sv;
$self->{'_params'}->{'-version'} = $sv;
}
if ($topology eq "circular") {
$self->{'_params'}->{'-is_circular'} = 1;
}
if (defined $mol ) {
if ($mol =~ /DNA/) {
$alphabet='dna';
}
elsif ($mol =~ /RNA/) {
$alphabet='rna';
}
elsif ($mol =~ /AA/) {
$alphabet='protein';
}
}
} elsif ($idtype) { # has internal ';'
# Old style header (EMBL Release < 87, before June 2006)
if ($line =~ m{^(\S+)[^;]*;\s+(\S+)[^;]*;\s+(\S+)[^;]*;}) {
($name, $mol, $div) = ($1, $2, $3);
#$self->debug("[$name][$mol][$div]");
}
if($mol) {
if ( $mol =~ m{circular} ) {
$self->{'_params'}->{'-is_circular'} = 1;
$mol =~ s{circular }{};
}
if (defined $mol ) {
if ($mol =~ /DNA/) {
$alphabet='dna';
}
elsif ($mol =~ /RNA/) {
$alphabet='rna';
}
elsif ($mol =~ /AA/) {
$alphabet='protein';
}
}
}
} else {
$name = $data->{DATA};
}
unless( defined $name && length($name) ) {
$name = "unknown_id";
}
$self->{'_params'}->{'-display_id'} = $name;
$self->{'_params'}->{'-alphabet'} = $alphabet;
$self->{'_params'}->{'-division'} = $div if $div;
$self->{'_params'}->{'-molecule'} = $mol if $mol;
}
# UniProt/SwissProt ID line
sub _swiss_id {
my ($self, $data) = @_;
my ($name, $seq_div);
if($data->{DATA} =~ m{^
(\S+) \s+ # $1 entryname
([^\s;]+); \s+ # $2 DataClass
(?:PRT;)? \s+ # Molecule Type (optional)
[0-9]+[ ]AA \. # Sequencelength (capture?)
$
}ox ) {
($name, $seq_div) = ($1, $2);
$self->{'_params'}->{'-namespace'} =
($seq_div eq 'Reviewed' || $seq_div eq 'STANDARD') ? 'Swiss-Prot' :
($seq_div eq 'Unreviewed' || $seq_div eq 'PRELIMINARY') ? 'TrEMBL' :
$seq_div;
# we shouldn't be setting the division, but for now...
my ($junk, $division) = split q(_), $name;
$self->{'_params'}->{'-division'} = $division;
$self->{'_params'}->{'-alphabet'} = 'protein';
# this is important to have the id for display in e.g. FTHelper, otherwise
# you won't know which entry caused an error
$self->{'_params'}->{'-display_id'} = $name;
} else {
$self->throw("Unrecognized UniProt/SwissProt ID line:[".$data->{DATA}."]");
}
}
# UniProt/SwissProt GN line
sub _swiss_genename {
my ($self, $data) = @_;
#$self->debug(Dumper($data));
my $genename = $data->{DATA};
my $gn;
if ($genename) {
my @stags;
if ($genename =~ /\w=\w/) {
# new format (e.g., Name=RCHY1; Synonyms=ZNF363, CHIMP)
for my $n (split(m{\s+and\s+},$genename)) {
my @genenames;
for my $section (split(m{\s*;\s*},$n)) {
my ($tag, $rest) = split("=",$section);
$rest ||= '';
for my $val (split(m{\s*,\s*},$rest)) {
push @genenames, [$tag => $val];
}
}
push @stags, ['gene_name' => \@genenames];
}
} else {
# old format
for my $section (split(/ AND /, $genename)) {
my @genenames;
$section =~ s/[\(\)\.]//g;
my @names = split(m{\s+OR\s+}, $section);
push @genenames, ['Name' => shift @names];
push @genenames, map {['Synonyms' => $_]} @names;
push @stags, ['gene_name' => \@genenames]
}
} #use Data::Dumper; print Dumper $gn, $genename;# exit;
my $gn = Bio::Annotation::TagTree->new(-tagname => 'gene_name',
-value => ['gene_names' => \@stags]);
$self->annotation_collection->add_Annotation('gene_name', $gn);
}
}
# GenBank VERSION line
# old EMBL SV line (now obsolete)
# UniProt/SwissProt?
sub _generic_version {
my ($self, $data) = @_;
my ($acc,$gi) = split(' ',$data->{DATA});
if($acc =~ m{^\w+\.(\d+)}xmso) {
$self->{'_params'}->{'-version'} = $1;
$self->{'_params'}->{'-seq_version'} = $1;
}
if($gi && (index($gi,"GI:") == 0)) {
$self->{'_params'}->{'-primary_id'} = substr($gi,3);
}
}
# EMBL DT lines
sub _embl_date {
my ($self, $data) = @_;
while ($data->{DATA} =~ m{(\S+)\s\((.*?)\)}g) {
my ($date, $version) = ($1, $2);
$date =~ tr{,}{}d; # remove comma if new version
if ($version =~ m{\(Rel\.\s(\d+),\sCreated\)}xmso ) {
my $release = Bio::Annotation::SimpleValue->new(
-tagname => 'creation_release',
-value => $1
);
$self->annotation_collection->add_Annotation($release);
} elsif ($version =~ m{\(Rel\.\s(\d+),\sLast\supdated,\sVersion\s(\d+)\)}xmso ) {
my $release = Bio::Annotation::SimpleValue->new(
-tagname => 'update_release',
-value => $1
);
$self->annotation_collection->add_Annotation($release);
my $update = Bio::Annotation::SimpleValue->new(
-tagname => 'update_version',
-value => $2
);
$self->annotation_collection->add_Annotation($update);
}
push @{ $self->{'_params'}->{'-dates'} }, $date;
}
}
# UniProt/SwissProt DT lines
sub _swiss_date {
my ($self, $data) = @_;
# swissprot
my @dls = split m{\n}, $data->{DATA};
for my $dl (@dls) {
my ($date, $version) = split(' ', $dl, 2);
$date =~ tr{,}{}d; # remove comma if new version
if ($version =~ m{\(Rel\. (\d+), Last sequence update\)} || # old
$version =~ m{sequence version (\d+)\.}) { #new
my $update = Bio::Annotation::SimpleValue->new(
-tagname => 'seq_update',
-value => $1
);
$self->annotation_collection->add_Annotation($update);
} elsif ($version =~ m{\(Rel\. (\d+), Last annotation update\)} || #old
$version =~ m{entry version (\d+)\.}) { #new
$self->{'_params'}->{'-version'} = $1;
$self->{'_params'}->{'-seq_version'} = $1;
}
push @{ $self->{'_params'}->{'-dates'} }, $date;
}
}
# GenBank KEYWORDS line
# EMBL KW line
# UniProt/SwissProt KW line
sub _generic_keywords {
my ($self, $data) = @_;
$data->{DATA} =~ s{\.$}{};
my @kw = split m{\s*\;\s*}xo ,$data->{DATA};
$self->{'_params'}->{'-keywords'} = \@kw;
}
# GenBank DEFINITION line
# EMBL DE line
# UniProt/SwissProt DE line
sub _generic_description {
my ($self, $data) = @_;
$self->{'_params'}->{'-desc'} = $data->{DATA};
}
# GenBank ACCESSION line
# EMBL AC line
# UniProt/SwissProt AC line
sub _generic_accession {
my ($self, $data) = @_;
my @accs = split m{[\s;]+}, $data->{DATA};
$self->{'_params'}->{'-accession_number'} = shift @accs;
$self->{'_params'}->{'-secondary_accessions'} = \@accs if @accs;
}
####################### SPECIES HANDLERS #######################
# uses Bio::Species
# GenBank SOURCE, ORGANISM lines
# EMBL O* lines
# UniProt/SwissProt O* lines
sub _generic_species {
my ($self, $data) = @_;
my $seqformat = $self->format;
# if data is coming in from GenBank parser...
if ($seqformat eq 'genbank' &&
$data->{ORGANISM} =~ m{(.+?)\s(\S+;[^\n\.]+)}ox) {
($data->{ORGANISM}, $data->{CLASSIFICATION}) = ($1, $2);
}
# SwissProt stuff...
# hybrid names in swissprot files are no longer valid per intergration into
# UniProt. Files containing these have been split into separate entries, so
# it is probably a good idea to update if one has these lingering around...
my $taxid;
if ($seqformat eq 'swiss') {
if ($data->{DATA} =~ m{^([^,]+)}ox) {
$data->{DATA} = $1;
}
if ($data->{CROSSREF} && $data->{CROSSREF} =~ m{NCBI_TaxID=(\d+)}) {
$taxid = $1;
}
}
my ($sl, $class, $sci_name) = ($data->{DATA},
$data->{CLASSIFICATION},
$data->{ORGANISM} || '');
my ($organelle,$abbr_name, $common);
my @class = reverse split m{\s*;\s*}, $class;
# have to treat swiss different from everything else...
if ($sl =~ m{^(mitochondrion|chloroplast|plastid)? # GenBank format
\s*(.*?)
\s*(?: \( (.*?) \) )?\.?$
}xmso ){
($organelle, $abbr_name, $common) = ($1, $2, $3); # optional
} else {
$abbr_name = $sl; # nothing caught; this is a backup!
}
# there is no 'abbreviated name' for EMBL
$sci_name = $abbr_name if $seqformat ne 'genbank';
$organelle ||= '';
$common ||= '';
$sci_name || return;
unshift @class, $sci_name;
# no genus/species parsing here; moving to Bio::Taxon-based taxonomy
my $make = Bio::Species->new();
$make->scientific_name($sci_name);
$make->classification(@class) if @class > 0;
$common && $make->common_name( $common );
$abbr_name && $make->name('abbreviated', $abbr_name);
$organelle && $make->organelle($organelle);
$taxid && $make->ncbi_taxid($taxid);
$self->{'_params'}->{'-species'} = $make;
}
####################### ANNOTATION HANDLERS #######################
# GenBank DBSOURCE line
sub _genbank_dbsource {
my ($self, $data) = @_;
my $dbsource = $data->{DATA};
my $annotation = $self->annotation_collection;
# deal with swissprot dbsources
# we could possibly parcel these out to subhandlers...
if( $dbsource =~ s/(UniProt(?:KB)|swissprot):\s+locus\s+(\S+)\,.+\n// ) {
$annotation->add_Annotation
('dblink',
Bio::Annotation::DBLink->new
(-primary_id => $2,
-database => $1,
-tagname => 'dblink'));
if( $dbsource =~ s/\s*created:\s+([^\.]+)\.\n// ) {
$annotation->add_Annotation
('swissprot_dates',
Bio::Annotation::SimpleValue->new
(-tagname => 'date_created',
-value => $1));
}
while( $dbsource =~ s/\s*(sequence|annotation)\s+updated:\s+([^\.]+)\.\n//g ) {
$annotation->add_Annotation
('swissprot_dates',
Bio::Annotation::SimpleValue->new
(-tagname => 'date_updated',
-value => $1));
}
$dbsource =~ s/\n/ /g;
if( $dbsource =~ s/\s*xrefs:\s+((?:\S+,\s+)+\S+)\s+xrefs/xrefs/ ) {
# will use $i to determine even or odd
# for swissprot the accessions are paired
my $i = 0;
for my $dbsrc ( split(/,\s+/,$1) ) {
if( $dbsrc =~ /(\S+)\.(\d+)/ || $dbsrc =~ /(\S+)/ ) {
my ($id,$version) = ($1,$2);
$version ='' unless defined $version;
my $db;
if( $id =~ /^\d\S{3}/) {
$db = 'PDB';
} else {
$db = ($i++ % 2 ) ? 'GenPept' : 'GenBank';
}
$annotation->add_Annotation
('dblink',
Bio::Annotation::DBLink->new
(-primary_id => $id,
-version => $version,
-database => $db,
-tagname => 'dblink'));
}
}
} elsif( $dbsource =~ s/\s*xrefs:\s+(.+)\s+xrefs/xrefs/i ) {
# download screwed up and ncbi didn't put acc in for gi numbers
my $i = 0;
for my $id ( split(/\,\s+/,$1) ) {
my ($acc,$db);
if( $id =~ /gi:\s+(\d+)/ ) {
$acc= $1;
$db = ($i++ % 2 ) ? 'GenPept' : 'GenBank';
} elsif( $id =~ /pdb\s+accession\s+(\S+)/ ) {
$acc= $1;
$db = 'PDB';
} else {
$acc= $id;
$db = '';
}
$annotation->add_Annotation
('dblink',
Bio::Annotation::DBLink->new
(-primary_id => $acc,
-database => $db,
-tagname => 'dblink'));
}
} else {
$self->warn("Cannot match $dbsource\n");
}
if( $dbsource =~ s/xrefs\s+\(non\-sequence\s+databases\):\s+
((?:\S+,\s+)+\S+)//x ) {
for my $id ( split(/\,\s+/,$1) ) {
my $db;
# this is because GenBank dropped the spaces!!!
# I'm sure we're not going to get this right
##if( $id =~ s/^://i ) {
## $db = $1;
##}
$db = substr($id,0,index($id,':'));
if (! exists $DBSOURCE{ $db }) {
$db = ''; # do we want 'GenBank' here?
}
$id = substr($id,index($id,':')+1);
$annotation->add_Annotation
('dblink',Bio::Annotation::DBLink->new
(-primary_id => $id,
-database => $db,
-tagname => 'dblink'));
}
}
} else {
if( $dbsource =~ /^(\S*?):?\s*accession\s+(\S+)\.(\d+)/ ) {
my ($db,$id,$version) = ($1,$2,$3);
$annotation->add_Annotation
('dblink',
Bio::Annotation::DBLink->new
(-primary_id => $id,
-version => $version,
-database => $db || 'GenBank',
-tagname => 'dblink'));
} elsif ( $dbsource =~ /(\S+)([\.:])(\d+)/ ) {
my ($id, $db, $version);
if ($2 eq ':') {
($db, $id) = ($1, $3);
} else {
($db, $id, $version) = ('GenBank', $1, $3);
}
$annotation->add_Annotation('dblink',
Bio::Annotation::DBLink->new(
-primary_id => $id,
-version => $version,
-database => $db,
-tagname => 'dblink')
);
} else {
$self->warn("Unrecognized DBSOURCE data: $dbsource\n");
}
}
}
# EMBL DR lines
# UniProt/SwissProt DR lines
sub _generic_dbsource {
my ($self, $data) = @_;
#$self->debug(Dumper($data));
while ($data->{DATA} =~ m{([^\n]+)}og) {
my $dblink = $1;
$dblink =~ s{\.$}{};
my $link;
my @linkdata = split '; ',$dblink;
if ( $dblink =~ m{([^\s;]+);\s*([^\s;]+);?\s*([^\s;]+)?}) {
#if ( $dblink =~ m{([^\s;]+);\s*([^\s;]+);?\s*([^\s;]+)?}) {
my ($databse, $prim_id, $sec_id) = ($1,$2,$3);
$link = Bio::Annotation::DBLink->new(-database => $databse,
-primary_id => $prim_id,
-optional_id => $sec_id);
} else {
$self->warn("No match for $dblink");
}
$self->annotation_collection->add_Annotation('dblink', $link);
}
}
# GenBank REFERENCE and related lines
# EMBL R* lines
# UniProt/SwissProt R* lines
sub _generic_reference {
my ($self, $data) = @_;
my $seqformat = $self->format;
my ($start, $end);
# get these in EMBL/Swiss
if ($data->{CROSSREF}) {
while ($data->{CROSSREF} =~ m{(pubmed|doi|medline)(?:=|;\s+)(\S+)}oig) {
my ($db, $ref) = (uc $1, $2);
$ref =~ s{[;.]+$}{};
$data->{$db} = $ref;
}
}
# run some cleanup for swissprot
if ($seqformat eq 'swiss') {
for my $val (values %{ $data }) {
$val =~ s{;$}{};
$val =~ s{(\w-)\s}{$1};
}
}
if ( $data->{POSITION} ) {
if ($seqformat eq 'embl') {
($start, $end) = split '-', $data->{POSITION},2;
} elsif ($data->{POSITION} =~ m{.+? OF (\d+)-(\d+).*}) { #swiss
($start, $end) = ($1, $2);
}
}
if ($data->{DATA} =~ m{^\d+\s+\([a-z]+\s+(\d+)\s+to\s+(\d+)\)}xmso) {
($start, $end) = ($1, $2);
}
my $ref = Bio::Annotation::Reference->new(
-comment => $data->{REMARK},
-location => $data->{JOURNAL},
-pubmed => $data->{PUBMED},
-consortium => $data->{CONSRTM},
-title => $data->{TITLE},
-authors => $data->{AUTHORS},
-medline => $data->{MEDLINE},
-doi => $data->{DOI},
-rp => $data->{POSITION}, # JIC...
-start => $start,
-end => $end,
);
if ($data->{DATA} =~ m{^\d+\s+\((.*)\)}xmso) {
$ref->gb_reference($1);
}
$self->annotation_collection->add_Annotation('reference', $ref);
}
# GenBank COMMENT lines
# EMBL CC lines
# UniProt/SwissProt CC lines
sub _generic_comment {
my ($self, $data) = @_;
$self->annotation_collection->add_Annotation('comment',
Bio::Annotation::Comment->new( -text => $data->{DATA} ));
}
####################### SEQFEATURE HANDLER #######################
# GenBank Feature Table
sub _generic_seqfeatures {
my ($self, $data) = @_;
return if $data->{FEATURE_KEY} eq 'FEATURES';
my $primary_tag = $data->{FEATURE_KEY};
# grab the NCBI taxon ID from the source SF
if ($primary_tag eq 'source' && exists $data->{'db_xref'}) {
if ( $self->{'_params'}->{'-species'} &&
$data->{'db_xref'} =~ m{taxon:(\d+)}xmso ) {
$self->{'_params'}->{'-species'}->ncbi_taxid($1);
}
}
my $source = $self->format;
my $seqid = ${ $self->get_params('accession_number') }{'accession_number'};
my $loc;
eval {
$loc = $self->{'_locfactory'}->from_string($data->{'LOCATION'});
};
if(! $loc) {
$self->warn("exception while parsing location line [" .
$data->{'LOCATION'} .
"] in reading $source, ignoring feature " .
$data->{'primary_tag'}.
" (seqid=" . $seqid . "): " . $@);
return;
}
if($seqid && (! $loc->is_remote())) {
$loc->seq_id($seqid); # propagates if it is a split location
}
my $sf = Bio::SeqFeature::Generic->direct_new();
$sf->location($loc);
$sf->primary_tag($primary_tag);
$sf->seq_id($seqid);
$sf->source_tag($source);
delete $data->{'FEATURE_KEY'};
delete $data->{'LOCATION'};
delete $data->{'NAME'};
delete $data->{'DATA'};
$sf->set_attributes(-tag => $data);
push @{ $self->{'_params'}->{'-features'} }, $sf;
}
####################### ODDS AND ENDS #######################
# Those things that don't fit anywhere else. If a specific name
# maps to the below table, that class and method are used, otherwise
# it goes into a SimpleValue (I think this is a good argument for why
# we need a generic mechanism for storing annotation)
sub _generic_simplevalue {
my ($self, $data) = @_;
$self->annotation_collection->add_Annotation(
Bio::Annotation::SimpleValue->new(-tagname => lc($data->{NAME}),
-value => $data->{DATA})
);
}
sub noop {}
sub _debug {
my ($self, $data) = @_;
$self->debug(Dumper($data));
}
1;