|
0
|
1 # $Id: game.pm,v 1.26.2.1 2003/06/28 22:23:15 jason Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::SeqIO::game
|
|
|
4 #
|
|
|
5 # Cared for by Brad Marshall <bradmars@yahoo.com>
|
|
|
6 #
|
|
|
7 # Copyright Ewan Birney & Lincoln Stein & Brad Marshall
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10 # _history
|
|
|
11 # June 25, 2000 written by Brad Marshall
|
|
|
12 #
|
|
|
13 # POD documentation - main docs before the code
|
|
|
14
|
|
|
15 =head1 NAME
|
|
|
16
|
|
|
17 Bio::SeqIO::game - Parses GAME XML 0.1 and higher into and out of Bio::Seq objects.
|
|
|
18
|
|
|
19 =head1 SYNOPSIS
|
|
|
20
|
|
|
21 To use this module you need XML::Parser, XML::Parser::PerlSAX
|
|
|
22 and XML::Writer.
|
|
|
23
|
|
|
24 Do not use this module directly. Use it via the Bio::SeqIO class.
|
|
|
25
|
|
|
26 =head1 DESCRIPTION
|
|
|
27
|
|
|
28 This object can transform Bio::Seq objects to and from bioxml seq,
|
|
|
29 computation, feature and annotation dtds,versions 0.1 and higher.
|
|
|
30 These can be found at http://www.bioxml.org/dtds/current. It does
|
|
|
31 this using the idHandler, seqHandler and featureHandler modules you
|
|
|
32 should have gotten with this one.
|
|
|
33
|
|
|
34 The idea is that any bioxml features can be turned into bioperl
|
|
|
35 annotations. When Annotations and computations are parsed in, they
|
|
|
36 gain additional info in the bioperl SeqFeature tag attribute. These
|
|
|
37 can be used to reconstitute a computation or annotation by the bioxml
|
|
|
38 with the bx-handler module when write_seq is called.
|
|
|
39
|
|
|
40 If you use this to write SeqFeatures that were not generated from
|
|
|
41 computations or annotations, it will output a list of bioxml features.
|
|
|
42 Some data may be lost in this step, since bioxml features just have a
|
|
|
43 span, type and description - nothing about the anlysis performed.
|
|
|
44
|
|
|
45 =head1 FEEDBACK
|
|
|
46
|
|
|
47 =head2 Mailing Lists
|
|
|
48
|
|
|
49 User feedback is an integral part of the evolution of this
|
|
|
50 and other Bioperl modules. Send your comments and suggestions preferably
|
|
|
51 to one of the Bioperl mailing lists.
|
|
|
52 Your participation is much appreciated.
|
|
|
53
|
|
|
54 bioperl-l@bioperl.org - Technical bioperl discussion
|
|
|
55 bioxml-dev@bioxml.org - Technical discussion - Moderate volume
|
|
|
56 bioxml-announce@bioxml.org - General Announcements - Pretty dead
|
|
|
57 http://www.bioxml.org/MailingLists/ - About the mailing lists
|
|
|
58
|
|
|
59 =head1 AUTHOR - Brad Marshall & Ewan Birney & Lincoln Stein
|
|
|
60
|
|
|
61 Email: bradmars@yahoo.com
|
|
|
62 birney@sanger.ac.uk
|
|
|
63 lstein@cshl.org
|
|
|
64
|
|
|
65
|
|
|
66 =head1 CONTRIBUTORS
|
|
|
67
|
|
|
68 Jason Stajich E<lt>jason@bioperl.orgE<gt>
|
|
|
69
|
|
|
70 =head1 APPENDIX
|
|
|
71
|
|
|
72 The rest of the documentation details each of the object
|
|
|
73 methods. Internal methods are usually preceded with a _
|
|
|
74
|
|
|
75 =cut
|
|
|
76
|
|
|
77 # Let the code begin...
|
|
|
78
|
|
|
79 package Bio::SeqIO::game;
|
|
|
80 use vars qw(@ISA);
|
|
|
81 use strict;
|
|
|
82 # Object preamble - inherits from Bio::Root::Object
|
|
|
83
|
|
|
84 use Bio::SeqIO;
|
|
|
85 use Bio::SeqIO::game::seqHandler;
|
|
|
86 use Bio::SeqIO::game::featureHandler;
|
|
|
87 use Bio::SeqIO::game::idHandler;
|
|
|
88 use XML::Parser::PerlSAX;
|
|
|
89 use Bio::SeqFeature::Generic;
|
|
|
90 use XML::Writer;
|
|
|
91
|
|
|
92 use Bio::Seq;
|
|
|
93
|
|
|
94 @ISA = qw(Bio::SeqIO);
|
|
|
95
|
|
|
96
|
|
|
97 sub _initialize {
|
|
|
98 my($self,@args) = @_;
|
|
|
99 $self->SUPER::_initialize(@args);
|
|
|
100 my $xmlfile = "";
|
|
|
101 $self->{'counter'} = 0;
|
|
|
102 $self->{'id_counter'} = 1;
|
|
|
103 $self->{'leftovers'} = undef;
|
|
|
104 $self->{'header'} = undef;
|
|
|
105 $self->{'chunkable'} = undef;
|
|
|
106 $self->{'xmldoc'} = undef;
|
|
|
107
|
|
|
108 $self->_export_subfeatures(1);
|
|
|
109 $self->_group_subfeatures(1);
|
|
|
110 $self->_subfeature_types('exons', 'promoters','poly_A_sites',
|
|
|
111 'utrs','introns','sub_SeqFeature');
|
|
|
112
|
|
|
113 # filehandle is stored by superclass _initialize
|
|
|
114 }
|
|
|
115
|
|
|
116
|
|
|
117 =head2 _export_subfeatures
|
|
|
118
|
|
|
119 Title : _export_subfeatures
|
|
|
120 Usage : $obj->_export_subfeatures
|
|
|
121 Function: export all subfeatures (also in the geneprediction structure)
|
|
|
122 Returns : value of _export_subfeatures
|
|
|
123 Args : newvalue (optional)
|
|
|
124
|
|
|
125 =cut
|
|
|
126
|
|
|
127 sub _export_subfeatures{
|
|
|
128 my $obj = shift;
|
|
|
129 if( @_ ) {
|
|
|
130 my $value = shift;
|
|
|
131 $obj->{'_export_subfeatures'} = $value;
|
|
|
132 }
|
|
|
133 return $obj->{'_export_subfeatures'};
|
|
|
134
|
|
|
135 }
|
|
|
136
|
|
|
137 =head2 _group_subfeatures
|
|
|
138
|
|
|
139 Title : _group_subfeatures
|
|
|
140 Usage : $obj->_group_subfeatures
|
|
|
141 Function: Groups all subfeatures in separate feature_sets
|
|
|
142 Returns : value of _group_subfeatures
|
|
|
143 Args : newvalue (optional)
|
|
|
144
|
|
|
145 =cut
|
|
|
146
|
|
|
147 sub _group_subfeatures{
|
|
|
148 my $obj = shift;
|
|
|
149 if( @_ ) {
|
|
|
150 my $value = shift;
|
|
|
151 $obj->{'_group_subfeatures'} = $value;
|
|
|
152 }
|
|
|
153 return $obj->{'_group_subfeatures'};
|
|
|
154 }
|
|
|
155
|
|
|
156 =head2 _subfeature_types
|
|
|
157
|
|
|
158 Title : _subfeature_types
|
|
|
159 Usage : $obj->_subfeature_types
|
|
|
160 Function: array of all possible subfeatures, it should be a
|
|
|
161 name of a function which
|
|
|
162 : returns an arrau of sub_seqfeatures when called:
|
|
|
163 @array = $feature->subfeaturetype()
|
|
|
164 Returns : array of _subfeature_types
|
|
|
165 Args : array of subfeature types (optional)
|
|
|
166
|
|
|
167 =cut
|
|
|
168
|
|
|
169 sub _subfeature_types{
|
|
|
170 my $obj = shift;
|
|
|
171 if( @_ ) {
|
|
|
172 my @values = @_;
|
|
|
173 $obj->{'_subfeature_types'} = \@values;
|
|
|
174 }
|
|
|
175 return @{$obj->{'_subfeature_types'}};
|
|
|
176
|
|
|
177 }
|
|
|
178
|
|
|
179 =head2 _add_subfeature_type
|
|
|
180
|
|
|
181 Title : _add_subfeature_type
|
|
|
182 Usage : $obj->_add_subfeature_type
|
|
|
183 Function: add one possible subfeature, it should be a name of a function which
|
|
|
184 : returns an arrau of sub_seqfeatures when called: @array = $feature->subfeaturetyp()
|
|
|
185 Returns : 1
|
|
|
186 Args : one subfeature type (optional)
|
|
|
187
|
|
|
188 =cut
|
|
|
189
|
|
|
190 sub _add_subfeature_type{
|
|
|
191 my $obj = shift;
|
|
|
192 if( @_ ) {
|
|
|
193 my @values = @_;
|
|
|
194 push @{$obj->{'_subfeature_types'}}, @values;
|
|
|
195 }
|
|
|
196 return 1;
|
|
|
197
|
|
|
198 }
|
|
|
199
|
|
|
200
|
|
|
201 =head2 next_seq
|
|
|
202
|
|
|
203 Title : next_seq
|
|
|
204 Usage : $seq = $stream->next_seq()
|
|
|
205 Function: returns the next sequence in the stream
|
|
|
206 Returns : Bio::Seq object
|
|
|
207 Args : NONE
|
|
|
208
|
|
|
209 =cut
|
|
|
210
|
|
|
211 sub next_seq {
|
|
|
212 my $self = shift;
|
|
|
213
|
|
|
214
|
|
|
215 # The header is the top level stuff in the XML file.
|
|
|
216 # IE before the first <bx-seq:seq> tag.
|
|
|
217 # If you don't include this in each 'chunk', the
|
|
|
218 # parser will barf.
|
|
|
219 my $header;
|
|
|
220 unless ($self->{'header'}) {
|
|
|
221 while (my $next_line = $self->_readline) {
|
|
|
222 if($next_line=~/<bx-seq:seq?/) {
|
|
|
223 $header .= $`;
|
|
|
224 $self->{'header'}=$header;
|
|
|
225 $self->{'leftovers'} .= "<bx-seq:seq".$';
|
|
|
226 last;
|
|
|
227 } else {
|
|
|
228 $header .= $next_line;
|
|
|
229 }
|
|
|
230 }
|
|
|
231 if ($self->{'header'}=~m|<bx-game:flavor>.*chunkable.*</bx-game:flavor>|) {
|
|
|
232 $self->{'chunkable'}=1;
|
|
|
233 }
|
|
|
234
|
|
|
235 }
|
|
|
236
|
|
|
237 my $not_top_level;
|
|
|
238 my $xmldoc;
|
|
|
239 my $seq;
|
|
|
240 # If chunkable, we read in the document until the next
|
|
|
241 # TOP LEVEL sequence.
|
|
|
242 if ($self->{'chunkable'}) {
|
|
|
243 $xmldoc = $self->{'header'}.$self->{'leftovers'};
|
|
|
244 while (my $next_line = $self->_readline) {
|
|
|
245 # Maintain depth of computations and annotations.
|
|
|
246 # We only want TOP LEVEL seqs if chunkable.
|
|
|
247 while ($next_line=~ m|<bx-computation:computation|g) {
|
|
|
248 $not_top_level++;
|
|
|
249 }
|
|
|
250 while ($next_line=~ m|<bx-annotation:annotation|g) {
|
|
|
251 $not_top_level++;
|
|
|
252 }
|
|
|
253 while ($next_line=~ m|</bx-computation:computation|g) {
|
|
|
254 $not_top_level--;
|
|
|
255 }
|
|
|
256 while ($next_line=~ m|</bx-annotation:annotation|g) {
|
|
|
257 $not_top_level--;
|
|
|
258 }
|
|
|
259 if($next_line=~/<bx-seq:seq?/) {
|
|
|
260 if (!$not_top_level) {
|
|
|
261 $xmldoc .= $`;
|
|
|
262 $self->{'leftovers'} .= "<bx-seq:seq".$';
|
|
|
263 last;
|
|
|
264 }
|
|
|
265 } else {
|
|
|
266 $xmldoc .= $next_line;
|
|
|
267 }
|
|
|
268 }
|
|
|
269 # Make sure the 'doc chunk' has a closing tag
|
|
|
270 # to make the parser happy.
|
|
|
271 if (!$xmldoc=~m|</bx-game:game>|){
|
|
|
272 $xmldoc .= "</bx-game:game>";
|
|
|
273 }
|
|
|
274 # Grab the TOP LEVEL seq..
|
|
|
275 if ($xmldoc =~ m|</bx-seq:seq|) {
|
|
|
276 my $handler = Bio::SeqIO::game::idHandler->new();
|
|
|
277 my $options = {Handler=>$handler};
|
|
|
278 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
279 $self->{'seqs'} = $parser->parse(Source => { String => $xmldoc });
|
|
|
280 } else { # No sequences.
|
|
|
281 return 0;
|
|
|
282 }
|
|
|
283 # Get the seq out of the array.
|
|
|
284 $seq = @{$self->{'seqs'}}[0];
|
|
|
285 # If not chunkable,
|
|
|
286 # only read document into memory once!
|
|
|
287 } elsif (!$self->{'xmldoc'}) {
|
|
|
288 $self->{'xmldoc'}=$self->{'header'}.$self->{'leftovers'};
|
|
|
289 while (my $next_line = $self->_readline) {
|
|
|
290 $self->{'xmldoc'} .= $next_line;
|
|
|
291 }
|
|
|
292 $xmldoc=$self->{'xmldoc'};
|
|
|
293 # Get the seq id index.
|
|
|
294 if ($xmldoc =~ m|</bx-seq:seq|) {
|
|
|
295 my $handler = Bio::SeqIO::game::idHandler->new();
|
|
|
296 my $options = {Handler=>$handler};
|
|
|
297 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
298 $self->{'seqs'} = $parser->parse(Source => { String => $xmldoc });
|
|
|
299 $seq = shift @{$self->{'seqs'}};
|
|
|
300 } else { # No sequences.
|
|
|
301 return 0;
|
|
|
302 }
|
|
|
303 my $seq = @{$self->{'seqs'}}[0];
|
|
|
304 # if we already have the doc in memory,
|
|
|
305 # just get the doc.
|
|
|
306 } elsif ($self->{'xmldoc'}) {
|
|
|
307 $xmldoc=$self->{'xmldoc'};
|
|
|
308 $seq = shift @{$self->{'seqs'}};
|
|
|
309 }
|
|
|
310 # If there's more sequences:
|
|
|
311 if ($seq) {
|
|
|
312 # Get the next seq.
|
|
|
313 my $handler = Bio::SeqIO::game::seqHandler->new(-seq => $seq);
|
|
|
314 my $options = {Handler=>$handler};
|
|
|
315 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
316 my $pseq = $parser->parse(Source => { String => $xmldoc });
|
|
|
317 # get the features.
|
|
|
318 my $fhandler = Bio::SeqIO::game::featureHandler->new($pseq->id(),
|
|
|
319 $pseq->length(),
|
|
|
320 $pseq->alphabet());
|
|
|
321 $options = {Handler=>$fhandler};
|
|
|
322
|
|
|
323 $parser = XML::Parser::PerlSAX->new($options);
|
|
|
324 my $features = $parser->parse(Source => { String => $xmldoc });
|
|
|
325 my $seq = Bio::Seq->new();
|
|
|
326 # Build the Bioperl Seq and return it.
|
|
|
327 foreach my $feature (@{$features}) {
|
|
|
328 $seq->add_SeqFeature($feature);
|
|
|
329 }
|
|
|
330 $seq->primary_seq($pseq);
|
|
|
331 return $seq;
|
|
|
332 } else {
|
|
|
333 return 0;
|
|
|
334 }
|
|
|
335 }
|
|
|
336
|
|
|
337 =head2 next_primary_seq
|
|
|
338
|
|
|
339 Title : next_primary_seq
|
|
|
340 Usage : $seq = $stream->next_primary_seq()
|
|
|
341 Function: returns the next primary sequence (ie no seq_features) in the stream
|
|
|
342 Returns : Bio::PrimarySeq object
|
|
|
343 Args : NONE
|
|
|
344
|
|
|
345 =cut
|
|
|
346
|
|
|
347 sub next_primary_seq {
|
|
|
348 my $self=shift;
|
|
|
349
|
|
|
350 # The header is the top level stuff in the XML file.
|
|
|
351 # IE before the first <bx-seq:seq> tag.
|
|
|
352 # If you don't include this in each 'chunk', the
|
|
|
353 # parser will barf.
|
|
|
354 my $header;
|
|
|
355 unless ($self->{'header'}) {
|
|
|
356 while (my $next_line = $self->_readline) {
|
|
|
357 if($next_line=~/<bx-seq:seq?/) {
|
|
|
358 $header .= $`;
|
|
|
359 $self->{'header'}=$header;
|
|
|
360 $self->{'leftovers'} .= "<bx-seq:seq".$';
|
|
|
361 last;
|
|
|
362 } else {
|
|
|
363 $header .= $next_line;
|
|
|
364 }
|
|
|
365 }
|
|
|
366 if ($self->{'header'}=~m|<bx-game:flavor>.*chunkable.*</bx-game:flavor>|) {
|
|
|
367 $self->{'chunkable'}=1;
|
|
|
368 }
|
|
|
369
|
|
|
370 }
|
|
|
371
|
|
|
372 my $not_top_level = 0;
|
|
|
373 my $xmldoc;
|
|
|
374 my $seq;
|
|
|
375 # If chunkable, we read in the document until the next
|
|
|
376 # TOP LEVEL sequence.
|
|
|
377 if ($self->{'chunkable'}) {
|
|
|
378 $xmldoc = $self->{'header'}.$self->{'leftovers'};
|
|
|
379 while (my $next_line = $self->_readline) {
|
|
|
380 # Maintain depth of computations and annotations.
|
|
|
381 # We only want TOP LEVEL seqs if chunkable.
|
|
|
382 while ($next_line=~ m|<bx-computation:computation|g) {
|
|
|
383 $not_top_level++;
|
|
|
384 }
|
|
|
385 while ($next_line=~ m|<bx-annotation:annotationn|g) {
|
|
|
386 $not_top_level++;
|
|
|
387 }
|
|
|
388 while ($next_line=~ m|</bx-computation:computation|g) {
|
|
|
389 $not_top_level--;
|
|
|
390 }
|
|
|
391 while ($next_line=~ m|</bx-annotation:annotationn|g) {
|
|
|
392 $not_top_level--;
|
|
|
393 }
|
|
|
394 if($next_line=~/<bx-seq:seq?/) {
|
|
|
395 if (!$not_top_level) {
|
|
|
396 $xmldoc .= $`;
|
|
|
397 $self->{'leftovers'} .= "<bx-seq:seq".$';
|
|
|
398 last;
|
|
|
399 }
|
|
|
400 } else {
|
|
|
401 $xmldoc .= $next_line;
|
|
|
402 }
|
|
|
403 }
|
|
|
404 # Make sure the 'doc chunk' has a closing tag
|
|
|
405 # to make the parser happy.
|
|
|
406 if (!$xmldoc=~m|</bx-game:game>|){
|
|
|
407 $xmldoc .= "</bx-game:game>";
|
|
|
408 }
|
|
|
409 # Grab the TOP LEVEL seq..
|
|
|
410 if ($xmldoc =~ m|</bx-seq:seq|) {
|
|
|
411 my $handler = Bio::SeqIO::game::idHandler->new();
|
|
|
412 my $options = {Handler=>$handler};
|
|
|
413 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
414 $self->{'seqs'} = $parser->parse(Source => { String => $xmldoc });
|
|
|
415 } else { # No sequences.
|
|
|
416 return 0;
|
|
|
417 }
|
|
|
418 $seq = @{$self->{'seqs'}}[0];
|
|
|
419 # If not chunkable,
|
|
|
420 # only read document into memory once!
|
|
|
421 } elsif (!$self->{'xmldoc'}) {
|
|
|
422 $self->{'xmldoc'}=$self->{'header'}.$self->{'leftovers'};
|
|
|
423 while (my $next_line = $self->_readline) {
|
|
|
424 $self->{'xmldoc'} .= $next_line;
|
|
|
425 }
|
|
|
426 $xmldoc=$self->{'xmldoc'};
|
|
|
427 # Get the seq id index.
|
|
|
428 if ($xmldoc =~ m|</bx-seq:seq|) {
|
|
|
429 my $handler = Bio::SeqIO::game::idHandler->new();
|
|
|
430 my $options = {Handler=>$handler};
|
|
|
431 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
432 $self->{'seqs'} = $parser->parse(Source => { String => $xmldoc });
|
|
|
433 $seq = shift @{$self->{'seqs'}};
|
|
|
434 } else { # No sequences.
|
|
|
435 return 0;
|
|
|
436 }
|
|
|
437 my $seq = @{$self->{'seqs'}}[0];
|
|
|
438 # if we already have the doc in memory,
|
|
|
439 # just get the doc.
|
|
|
440 } elsif ($self->{'xmldoc'}) {
|
|
|
441 $xmldoc=$self->{'xmldoc'};
|
|
|
442 $seq = shift @{$self->{'seqs'}};
|
|
|
443 }
|
|
|
444
|
|
|
445 #print $xmldoc;
|
|
|
446
|
|
|
447 if ($seq) {
|
|
|
448 # Get the next seq.
|
|
|
449 my $handler = Bio::SeqIO::game::seqHandler->new(-seq => $seq);
|
|
|
450 my $options = {Handler=>$handler};
|
|
|
451 my $parser = XML::Parser::PerlSAX->new($options);
|
|
|
452 my $pseq = $parser->parse(Source => { String => $xmldoc });
|
|
|
453 return $pseq;
|
|
|
454 } else {
|
|
|
455 return 0;
|
|
|
456 }
|
|
|
457 }
|
|
|
458
|
|
|
459
|
|
|
460 =head2 write_seq
|
|
|
461
|
|
|
462 Title : write_seq
|
|
|
463 Usage : Not Yet Implemented! $stream->write_seq(@seq)
|
|
|
464 Function: writes the $seq object into the stream
|
|
|
465 Returns : 1 for success and 0 for error
|
|
|
466 Args : Bio::Seq object
|
|
|
467
|
|
|
468
|
|
|
469 =cut
|
|
|
470
|
|
|
471 sub write_seq {
|
|
|
472 my ($self,@seqs) = @_;
|
|
|
473
|
|
|
474 my $bxfeat = "http://www.bioxml.org/dtds/current/feature.dtd";
|
|
|
475 my $bxann = "http://www.bioxml.org/dtds/current/annotation.dtd";
|
|
|
476 my $bxcomp = "http://www.bioxml.org/dtds/current/computation.dtd";
|
|
|
477 my $bxgame = "http://www.bioxml.org/dtds/current/game.dtd";
|
|
|
478 my $bxlink = "http://www.bioxml.org/dtds/current/link.dtd";
|
|
|
479 my $bxseq = "http://www.bioxml.org/dtds/current/seq.dtd";
|
|
|
480
|
|
|
481 my $writer = new XML::Writer(OUTPUT => $self->_fh || \*STDOUT,
|
|
|
482 NAMESPACES => 1,
|
|
|
483 DATA_MODE => 1,
|
|
|
484 DATA_INDENT => 4,
|
|
|
485 PREFIX_MAP => {
|
|
|
486 '' => '', # to keep undef warnings away in XML::Writer, fill in with something as a default prefix later?
|
|
|
487 $bxfeat => 'bx-feature',
|
|
|
488 $bxann => 'bx-annotation',
|
|
|
489 $bxcomp => 'bx-computation',
|
|
|
490 $bxgame => 'bx-game',
|
|
|
491 $bxlink => 'bx-link',
|
|
|
492 $bxseq => 'bx-seq'
|
|
|
493 });
|
|
|
494 $writer->xmlDecl("UTF-8");
|
|
|
495 $writer->doctype("bx-game:game", 'game', $bxgame);
|
|
|
496 $writer ->startTag ([$bxgame, 'game']);
|
|
|
497 $writer->startTag ([$bxgame, 'flavor']);
|
|
|
498 $writer->characters('chunkable');
|
|
|
499 $writer->endTag ([$bxgame, 'flavor']);
|
|
|
500
|
|
|
501 foreach my $seq (@seqs) {
|
|
|
502 $writer->startTag([$bxseq, 'seq'],
|
|
|
503 [$bxseq, 'id'] => $seq->display_id,
|
|
|
504 [$bxseq, 'length'] => $seq->length,
|
|
|
505 [$bxseq, 'type'] => $seq->alphabet);
|
|
|
506 if ($seq->length > 0) {
|
|
|
507 $writer->startTag([$bxseq, 'residues']);
|
|
|
508 $writer->characters($seq->seq);
|
|
|
509 $writer->endTag([$bxseq, 'residues']);
|
|
|
510 }
|
|
|
511 $writer->endTag([$bxseq, 'seq']);
|
|
|
512
|
|
|
513 my @feats = $seq->all_SeqFeatures;
|
|
|
514
|
|
|
515 my $features;
|
|
|
516 foreach my $feature (@feats) {
|
|
|
517 if ($feature->has_tag('annotation_id')) {
|
|
|
518 my @ann_id = $feature->each_tag_value('annotation_id');
|
|
|
519 push (@{$features->{'annotations'}->{$ann_id[0]}}, $feature);
|
|
|
520 } elsif ($feature->has_tag('computation_id')) {
|
|
|
521 my @comp_id = $feature->each_tag_value('computation_id');
|
|
|
522 push (@{$features->{'computations'}->{$comp_id[0]}}, $feature);
|
|
|
523 } else {
|
|
|
524 push (@{$features->{'everybody_else'}}, $feature);
|
|
|
525 }
|
|
|
526 }
|
|
|
527 foreach my $key (keys %{$features->{'annotations'}}) {
|
|
|
528 $writer->startTag([$bxann, 'annotation'],
|
|
|
529 [$bxann, 'id']=>$key
|
|
|
530 );
|
|
|
531 $writer->startTag([$bxann, 'seq_link']);
|
|
|
532 $writer->startTag([$bxlink, 'link']);
|
|
|
533 $writer->emptyTag([$bxlink, 'ref_link'],
|
|
|
534 [$bxlink, 'ref'] => $seq->display_id());
|
|
|
535 $writer->endTag([$bxlink, 'link']);
|
|
|
536 $writer->endTag([$bxann, 'seq_link']);
|
|
|
537 $self->__draw_feature_set($writer, $seq, $bxann, "", @{$features->{'annotations'}->{$key}});
|
|
|
538 $writer->endTag([$bxann, 'annotation']);
|
|
|
539 }
|
|
|
540
|
|
|
541 foreach my $key (keys %{$features->{'computations'}}) {
|
|
|
542 $writer->startTag([$bxcomp, 'computation'],
|
|
|
543 [$bxcomp, 'id']=>$key
|
|
|
544 );
|
|
|
545 $writer->startTag([$bxcomp, 'seq_link']);
|
|
|
546 $writer->startTag([$bxlink, 'link']);
|
|
|
547 $writer->emptyTag([$bxlink, 'ref_link'],
|
|
|
548 [$bxlink, 'ref'] => $seq->display_id());
|
|
|
549 $writer->endTag([$bxlink, 'link']);
|
|
|
550 $writer->endTag([$bxcomp, 'seq_link']);
|
|
|
551 $self->__draw_feature_set($writer, $seq, $bxcomp, "", @{$features->{'computations'}->{$key}});
|
|
|
552 $writer->endTag([$bxcomp, 'computation']);
|
|
|
553 }
|
|
|
554 foreach my $feature (@{$features->{'everybody_else'}}) {
|
|
|
555 $self->__draw_feature($writer, $feature, $seq, "",
|
|
|
556 $self->_export_subfeatures());
|
|
|
557 }
|
|
|
558 }
|
|
|
559 $writer->endTag([$bxgame, 'game']);
|
|
|
560
|
|
|
561 $self->flush if $self->_flush_on_write && defined $self->_fh;
|
|
|
562 return 1;
|
|
|
563 }
|
|
|
564
|
|
|
565
|
|
|
566 #these two subroutines are very specific!
|
|
|
567
|
|
|
568 sub __draw_feature_set {
|
|
|
569 my ($self, $writer, $seq, $namespace, $parent, @features) = @_;
|
|
|
570 my ($feature_set_id);
|
|
|
571
|
|
|
572 my $bxfeat = "http://www.bioxml.org/dtds/current/feature.dtd";
|
|
|
573
|
|
|
574 if ($self->_export_subfeatures() && $self->_group_subfeatures()) {
|
|
|
575 $feature_set_id = $self->{'id_counter'}; $self->{'id_counter'}++;
|
|
|
576 $writer->startTag([$namespace, 'feature_set'],
|
|
|
577 [$namespace, 'id'] => $feature_set_id);
|
|
|
578 foreach my $feature (@features) {
|
|
|
579 $self->__draw_feature($writer, $feature, $seq, $parent , 0);
|
|
|
580 }
|
|
|
581 $writer->endTag([$namespace, 'feature_set']);
|
|
|
582 foreach my $feature (@features) {
|
|
|
583 foreach my $subset ($self->_subfeature_types()) {
|
|
|
584 if (my @subfeatures = eval ( '$feature->' . $subset . '()' )) {
|
|
|
585 my @id = $feature->each_tag_value('id');
|
|
|
586 $self->__draw_feature_set($writer, $seq, $namespace, $id[0], @subfeatures);
|
|
|
587 }
|
|
|
588 }
|
|
|
589 }
|
|
|
590
|
|
|
591 } else {
|
|
|
592 $feature_set_id = $self->{'id_counter'}; $self->{'id_counter'}++;
|
|
|
593 $writer->startTag([$namespace, 'feature_set'],
|
|
|
594 [$namespace, 'id'] => $feature_set_id);
|
|
|
595 foreach my $feature (@features) {
|
|
|
596 $self->__draw_feature($writer, $feature, $seq, "" , $self->_export_subfeatures());
|
|
|
597 }
|
|
|
598 $writer->endTag([$namespace, 'feature_set']);
|
|
|
599 }
|
|
|
600 }
|
|
|
601
|
|
|
602
|
|
|
603 sub __draw_feature {
|
|
|
604 my ($self, $writer, $feature, $seq, $parent, $recursive) = @_;
|
|
|
605 my ($subfeature, $subset, @subfeatures, $score, $score_val, $score_no);
|
|
|
606 my $bxfeat = "http://www.bioxml.org/dtds/current/feature.dtd";
|
|
|
607
|
|
|
608 if (!$feature->has_tag('id')) {
|
|
|
609 $feature->add_tag_value('id', $self->{'id_counter'});
|
|
|
610 $self->{'id_counter'}++;
|
|
|
611 }
|
|
|
612
|
|
|
613 my @id = $feature->each_tag_value('id');
|
|
|
614 if ($parent) {
|
|
|
615 $writer->startTag([$bxfeat, 'feature'],
|
|
|
616 [$bxfeat, 'id'] => $id[0]
|
|
|
617 );
|
|
|
618 } else {
|
|
|
619 $writer->startTag([$bxfeat, 'feature'],
|
|
|
620 [$bxfeat, 'id'] => $id[0],
|
|
|
621 [$bxfeat, 'parent'] => $parent
|
|
|
622 );
|
|
|
623 }
|
|
|
624 $writer->startTag([$bxfeat, 'type']);
|
|
|
625 $writer->characters($feature->primary_tag());
|
|
|
626 $writer->endTag([$bxfeat, 'type']);
|
|
|
627 foreach $score ($feature->all_tags()) {
|
|
|
628 next if ($score eq 'id');
|
|
|
629 $writer->startTag([$bxfeat, 'score'],
|
|
|
630 [$bxfeat, 'type'] => $score
|
|
|
631 );
|
|
|
632 $score_no = 0;
|
|
|
633 foreach $score_val ($feature->each_tag_value($score)) {
|
|
|
634 next unless defined $score_val;
|
|
|
635 $writer->characters(' ') if ($score_no > 0);
|
|
|
636 $writer->characters($score_val);
|
|
|
637 $score_no++;
|
|
|
638 }
|
|
|
639 $writer->endTag([$bxfeat, 'score']);
|
|
|
640 }
|
|
|
641
|
|
|
642 $writer->startTag([$bxfeat, 'seq_relationship'],
|
|
|
643 [$bxfeat, 'seq'] => $seq->display_id,
|
|
|
644 [$bxfeat, 'type'] => 'query'
|
|
|
645 );
|
|
|
646
|
|
|
647 $writer->startTag([$bxfeat, 'span']);
|
|
|
648 $writer->startTag([$bxfeat, 'start']);
|
|
|
649 $writer->characters($feature->start());
|
|
|
650 $writer->endTag([$bxfeat, 'start']);
|
|
|
651 $writer->startTag([$bxfeat, 'end']);
|
|
|
652 $writer->characters($feature->end());
|
|
|
653 $writer->endTag([$bxfeat, 'end']);
|
|
|
654 $writer->endTag([$bxfeat, 'span']);
|
|
|
655 $writer->endTag([$bxfeat, 'seq_relationship']);
|
|
|
656 $writer->endTag([$bxfeat, 'feature']);
|
|
|
657
|
|
|
658 #proces subseqfeature's, exons, introns, promotors, whatever...
|
|
|
659 if ($recursive) {
|
|
|
660 foreach $subset ($self->_subfeature_types()) {
|
|
|
661 #determine if it exists
|
|
|
662 if (@subfeatures = eval ( '$feature->' . $subset . '()' )) {
|
|
|
663 foreach $subfeature (@subfeatures) {
|
|
|
664 $self->__draw_feature ($writer, $subfeature, $seq, $id[0], 1);
|
|
|
665 }
|
|
|
666 }
|
|
|
667 }
|
|
|
668 }
|
|
|
669 }
|
|
|
670
|
|
|
671 1;
|
|
|
672
|
