annotate variant_effect_predictor/Bio/SeqIO/chado.pm @ 1:d6778b5d8382 draft default tip

Deleted selected files
author willmclaren
date Fri, 03 Aug 2012 10:05:43 -0400
parents 21066c0abaf5
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
1 # $Id: chado.pm,v 1.1 2002/12/03 08:13:55 cjm Exp $
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
2 #
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
3 # BioPerl module for Bio::SeqIO::chado
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
4 #
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
5 # Chris Mungall <cjm@fruitfly.org>
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
6 #
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
7 # You may distribute this module under the same terms as perl itself
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
8
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
9 # POD documentation - main docs before the code
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
10
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
11 =head1 NAME
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
12
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
13 Bio::SeqIO::chado - chado sequence input/output stream
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
14
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
15 =head1 SYNOPSIS
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
16
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
17 It is probably best not to use this object directly, but
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
18 rather go through the SeqIO handler system. Go:
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
19
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
20 $stream = Bio::SeqIO->new(-file => $filename, -format => 'chado');
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
21
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
22 while ( my $seq = $stream->next_seq() ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
23 # do something with $seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
24 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
25
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
26 =head1 DESCRIPTION
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
27
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
28 This object can transform Bio::Seq objects to and from chado flat
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
29 file databases. CURRENTLY ONLY TO
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
30
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
31
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
32 =head2 Optional functions
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
33
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
34 =over 3
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
35
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
36 =item _show_dna()
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
37
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
38 (output only) shows the dna or not
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
39
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
40 =item _post_sort()
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
41
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
42 (output only) provides a sorting func which is applied to the FTHelpers
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
43 before printing
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
44
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
45
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
46 =back
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
47
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
48 =head1 FEEDBACK
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
49
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
50 =head2 Mailing Lists
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
51
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
52 User feedback is an integral part of the evolution of this
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
53 and other Bioperl modules. Send your comments and suggestions preferably
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
54 to one of the Bioperl mailing lists.
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
55 Your participation is much appreciated.
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
56
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
57 bioperl-l@bioperl.org - General discussion
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
58 http://www.bioperl.org/MailList.shtml - About the mailing lists
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
59
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
60 =head2 Reporting Bugs
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
61
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
62 Report bugs to the Bioperl bug tracking system to help us keep track
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
63 the bugs and their resolution.
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
64 Bug reports can be submitted via email or the web:
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
65
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
66 bioperl-bugs@bio.perl.org
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
67 http://bio.perl.org/bioperl-bugs/
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
68
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
69 =head1 AUTHOR - Chris Mungall
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
70
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
71 Email cjm@fruitfly.org
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
72
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
73 =head1 APPENDIX
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
74
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
75 The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
76
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
77 =cut
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
78
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
79 # Let the code begin...
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
80
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
81 package Bio::SeqIO::chado;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
82 use vars qw(@ISA);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
83 use strict;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
84
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
85 use Bio::SeqIO;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
86 use Bio::SeqFeature::Generic;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
87 use Bio::Species;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
88 use Bio::Seq::SeqFactory;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
89 use Bio::Annotation::Collection;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
90 use Bio::Annotation::Comment;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
91 use Bio::Annotation::Reference;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
92 use Bio::Annotation::DBLink;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
93
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
94 use Data::Stag qw(:all);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
95
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
96 @ISA = qw(Bio::SeqIO);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
97
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
98 sub _initialize {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
99 my($self,@args) = @_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
100
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
101 $self->SUPER::_initialize(@args);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
102 if( ! defined $self->sequence_factory ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
103 $self->sequence_factory(new Bio::Seq::SeqFactory
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
104 (-verbose => $self->verbose(),
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
105 -type => 'Bio::Seq::RichSeq'));
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
106 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
107 my $wclass = $self->default_handler_class;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
108 $self->handler($wclass->new);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
109 $self->{_end_of_data} = 0;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
110 $self->handler->S("chado");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
111 return;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
112 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
113
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
114 sub DESTROY {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
115 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
116 $self->end_of_data();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
117 $self->SUPER::DESTROY();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
118 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
119
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
120 sub end_of_data {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
121 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
122 $self->{_end_of_data} = 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
123 $self->handler->E("chado");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
124 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
125
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
126 sub default_handler_class {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
127 return "Data::Stag::BaseHandler";
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
128 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
129
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
130 =head2 next_seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
131
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
132 Title : next_seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
133 Usage : $seq = $stream->next_seq()
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
134 Function: returns the next sequence in the stream
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
135 Returns : Bio::Seq object
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
136 Args :
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
137
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
138 =cut
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
139
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
140 sub next_seq {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
141 my ($self,@args) = @_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
142 my $seq = $self->sequence_factory->create
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
143 (
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
144 # '-verbose' =>$self->verbose(),
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
145 # %params,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
146 # -seq => $seqc,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
147 # -annotation => $annotation,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
148 # -features => \@features
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
149 );
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
150 return $seq;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
151 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
152
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
153 sub handler {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
154 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
155 $self->{_handler} = shift if @_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
156 return $self->{_handler};
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
157 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
158
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
159
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
160 =head2 write_seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
161
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
162 Title : write_seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
163 Usage : $stream->write_seq($seq)
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
164 Function: writes the $seq object (must be seq) to the stream
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
165 Returns : 1 for success and 0 for error
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
166 Args : Bio::Seq
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
167
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
168
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
169 =cut
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
170
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
171 sub write_seq {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
172 my ($self,$seq) = @_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
173
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
174 if( !defined $seq ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
175 $self->throw("Attempting to write with no seq!");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
176 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
177
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
178 if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
179 $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
180 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
181
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
182 # get a handler - must inherit from Data::Stag::BaseHandler;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
183 my $w = $self->handler;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
184
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
185 # start of data
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
186 $w->S("seqset");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
187
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
188 # my $seq_temp_uid = $self->get_temp_uid($seq);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
189
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
190 my $seq_temp_uid = $seq->accession . '.' . ($seq->can('seq_version') ? $seq->seq_version : $seq->version);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
191
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
192 # data structure representing the core sequence for this record
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
193 my $seqnode =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
194 Data::Stag->new(feature=>[
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
195 [feature_id=>$seq_temp_uid],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
196 [dbxrefstr=>$seq->accession_number],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
197 [name=>$seq->display_name],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
198 [residues=>$seq->seq],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
199 ]);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
200
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
201 # soft properties
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
202 my %prop = ();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
203
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
204 my ($div, $mol);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
205 my $len = $seq->length();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
206
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
207 if ( $seq->can('division') ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
208 $div=$seq->division;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
209 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
210 if( !defined $div || ! $div ) { $div = 'UNK'; }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
211
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
212 if( !$seq->can('molecule') || ! defined ($mol = $seq->molecule()) ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
213 $mol = $seq->alphabet || 'DNA';
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
214 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
215
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
216
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
217 my $circular = 'linear ';
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
218 $circular = 'circular' if $seq->is_circular;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
219
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
220 # cheeky hack - access symbol table
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
221 no strict 'refs';
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
222 map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
223 $prop{$_} =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
224 $ {*$_};
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
225 } qw(mol div circular);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
226 use strict 'refs';
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
227
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
228 map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
229 $prop{$_} = $seq->$_() if $seq->can($_);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
230 } qw(desc keywords);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
231
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
232 local($^W) = 0; # supressing warnings about uninitialized fields.
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
233
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
234 # Organism lines
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
235 if (my $spec = $seq->species) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
236 my ($species, $genus, @class) = $spec->classification();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
237 my $OS;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
238 if( $spec->common_name ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
239 $OS = $spec->common_name;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
240 } else {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
241 $OS = "$genus $species";
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
242 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
243 if (my $ssp = $spec->sub_species) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
244 $OS .= " $ssp";
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
245 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
246 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
247
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
248 # Reference lines
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
249 my $count = 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
250 foreach my $ref ( $seq->annotation->get_Annotations('reference') ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
251 # TODO
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
252 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
253 # Comment lines
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
254
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
255 foreach my $comment ( $seq->annotation->get_Annotations('comment') ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
256 $seqnode->add_featureprop([[pkey=>'comment'],[pval=>$comment->text]]);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
257 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
258
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
259 # throw the writer an event
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
260 $w->ev(@$seqnode);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
261
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
262 $seqnode = undef; # free memory
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
263
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
264 # make events for all the features within the record
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
265 foreach my $sf ( $seq->top_SeqFeatures ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
266 $self->write_sf($sf, $seq_temp_uid);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
267 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
268
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
269 # data end
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
270 $w->E("seqset");
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
271 return 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
272 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
273
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
274 # ----
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
275 # writes a seq feature
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
276 # ----
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
277
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
278 sub write_sf {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
279 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
280 my $sf = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
281 my $seq_temp_uid = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
282
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
283 my $w = $self->handler;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
284
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
285 my %props =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
286 map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
287 $_=>[$sf->each_tag_value($_)]
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
288 } $sf->all_tags;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
289
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
290 my $loc = $sf->location;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
291 my $name = $sf->display_name;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
292 my $type = $sf->primary_tag;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
293 my @subsfs = $sf->sub_SeqFeature;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
294 my @locnodes = ();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
295 my $sid = $loc->is_remote ? $loc->seq_id : $seq_temp_uid;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
296 if( $loc->isa("Bio::Location::SplitLocationI") ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
297 # turn splitlocs into subfeatures
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
298 my $n = 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
299 push(@subsfs,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
300 map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
301 my $ssf =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
302 Bio::SeqFeature::Generic->new(
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
303
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
304 -start=>$_->start,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
305 -end=>$_->end,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
306 -strand=>$_->strand,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
307 -primary=>$self->subpartof($type),
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
308 );
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
309 if ($_->is_remote) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
310 $ssf->location->is_remote(1);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
311 $ssf->location->seq_id($_->seq_id);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
312 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
313 $ssf;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
314 } $loc->each_Location);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
315 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
316 elsif( $loc->isa("Bio::Location::RemoteLocationI") ) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
317 # turn splitlocs into subfeatures
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
318 my $n = 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
319 push(@subsfs,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
320 map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
321 Bio::SeqFeature::Generic->new(
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
322 # -name=>$name.'.'.$n++,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
323 -start=>$_->start,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
324 -end=>$_->end,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
325 -strand=>$_->strand,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
326 -primary=>$self->subpartof($type),
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
327 )
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
328 } $loc->each_Location);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
329 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
330 else {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
331 my ($beg, $end, $strand) = $self->bp2ib($loc);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
332 @locnodes = (
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
333 [featureloc=>[
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
334 [nbeg=>$beg],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
335 [nend=>$end],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
336 [strand=>$strand],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
337 [srcfeature_id=>$sid],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
338 [group=>0],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
339 [rank=>0],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
340 ]
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
341 ]
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
342 );
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
343 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
344 my $feature_id = $self->get_temp_uid($sf);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
345
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
346 my $fnode =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
347 [feature=>[
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
348 [feature_id=>$feature_id],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
349 [name=>$name],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
350 [typename=>$type],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
351 @locnodes,
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
352 (map {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
353 my $k = $_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
354 map { [featureprop=>[[pkey=>$k],[pval=>$_]]] } @{$props{$k}}
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
355 } keys %props),
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
356 ]];
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
357 $w->ev(@$fnode);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
358
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
359 foreach my $ssf (@subsfs) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
360 my $ssfid = $self->write_sf($ssf, $sid);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
361 $w->ev(feature_relationship=>[
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
362 [subjfeature_id=>$ssfid],
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
363 [objfeature_id=>$feature_id]
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
364 ]
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
365 );
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
366 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
367 return $feature_id;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
368 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
369
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
370 # private;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
371 # an ID for this session that should be
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
372 # unique... hmm
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
373 sub session_id {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
374 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
375 $self->{_session_id} = shift if @_;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
376 if (!$self->{_session_id}) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
377 $self->{_session_id} = $$.time;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
378 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
379 return $self->{_session_id};
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
380 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
381
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
382
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
383 our $next_id = 1;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
384 our %obj2id_hash = ();
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
385 sub get_temp_uid {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
386 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
387 my $ob = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
388 my $id = $obj2id_hash{$ob};
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
389 if (!$id) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
390 $id = $next_id++;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
391 $obj2id_hash{$ob} = $id;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
392 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
393 return $self->session_id.'.'.$id;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
394 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
395
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
396 # interbase and directional semantics
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
397 sub bp2ib {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
398 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
399 my $loc = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
400 my ($s, $e, $str) =
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
401 ref($loc) eq "ARRAY" ? (@$loc) : ($loc->start, $loc->end, $loc->strand);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
402 if ($str < 0) {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
403 ($s, $e) = ($e, $s);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
404 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
405 $s--;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
406 return ($s, $e, $str);
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
407 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
408
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
409 sub subpartof {
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
410 my $self = shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
411 my $type = 'partof_'.shift;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
412 $type =~ s/partof_CDS/CDS_exon/;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
413 $type =~ s/partof_\wRNA/exon/;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
414 return $type;
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
415 }
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
416
21066c0abaf5 Uploaded
willmclaren
parents:
diff changeset
417 1;