|
0
|
1 # $Id: PositionProxy.pm,v 1.4 2002/10/22 07:38:41 lapp Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::SeqFeature::PositionProxy
|
|
|
4 #
|
|
|
5 # Cared for by Ewan Birney <birney@ebi.ac.uk>
|
|
|
6 #
|
|
|
7 # Copyright Ewan Birney
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10
|
|
|
11 # POD documentation - main docs before the code
|
|
|
12
|
|
|
13 =head1 NAME
|
|
|
14
|
|
|
15 Bio::SeqFeature::PositionProxy - handle features when truncation/revcom sequences span a feature
|
|
|
16
|
|
|
17 =head1 SYNOPSIS
|
|
|
18
|
|
|
19 $proxy = new Bio::SeqFeature::PositionProxy ( -loc => $loc,
|
|
|
20 -parent => $basefeature);
|
|
|
21
|
|
|
22 $seq->add_SeqFeature($feat);
|
|
|
23
|
|
|
24
|
|
|
25
|
|
|
26 =head1 DESCRIPTION
|
|
|
27
|
|
|
28 PositionProxy is a Proxy Sequence Feature to handle truncation
|
|
|
29 and revcomp without duplicating all the data within the sequence features.
|
|
|
30 It holds a new location for a sequence feature and the original feature
|
|
|
31 it came from to provide the additional annotation information.
|
|
|
32
|
|
|
33 =head1 FEEDBACK
|
|
|
34
|
|
|
35 =head2 Mailing Lists
|
|
|
36
|
|
|
37 User feedback is an integral part of the evolution of this and other
|
|
|
38 Bioperl modules. Send your comments and suggestions preferably to one
|
|
|
39 of the Bioperl mailing lists. Your participation is much appreciated.
|
|
|
40
|
|
|
41 bioperl-l@bioperl.org - General discussion
|
|
|
42 http://bio.perl.org/MailList.html - About the mailing lists
|
|
|
43
|
|
|
44 =head2 Reporting Bugs
|
|
|
45
|
|
|
46 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
47 the bugs and their resolution. Bug reports can be submitted via email
|
|
|
48 or the web:
|
|
|
49
|
|
|
50 bioperl-bugs@bio.perl.org
|
|
|
51 http://bugzilla.bioperl.org/
|
|
|
52
|
|
|
53 =head1 AUTHOR - Ewan Birney
|
|
|
54
|
|
|
55 Ewan Birney E<lt>birney@sanger.ac.ukE<gt>
|
|
|
56
|
|
|
57 =head1 DEVELOPERS
|
|
|
58
|
|
|
59 This class has been written with an eye out of inheritence. The fields
|
|
|
60 the actual object hash are:
|
|
|
61
|
|
|
62 _gsf_tag_hash = reference to a hash for the tags
|
|
|
63 _gsf_sub_array = reference to an array for sub arrays
|
|
|
64 _gsf_start = scalar of the start point
|
|
|
65 _gsf_end = scalar of the end point
|
|
|
66 _gsf_strand = scalar of the strand
|
|
|
67
|
|
|
68 =head1 APPENDIX
|
|
|
69
|
|
|
70 The rest of the documentation details each of the object
|
|
|
71 methods. Internal methods are usually preceded with a _
|
|
|
72
|
|
|
73 =cut
|
|
|
74
|
|
|
75
|
|
|
76 # Let the code begin...
|
|
|
77
|
|
|
78
|
|
|
79 package Bio::SeqFeature::PositionProxy;
|
|
|
80 use vars qw(@ISA);
|
|
|
81 use strict;
|
|
|
82
|
|
|
83 use Bio::Root::Root;
|
|
|
84 use Bio::SeqFeatureI;
|
|
|
85 use Bio::Tools::GFF;
|
|
|
86
|
|
|
87
|
|
|
88 @ISA = qw(Bio::Root::Root Bio::SeqFeatureI);
|
|
|
89
|
|
|
90 sub new {
|
|
|
91 my ($caller, @args) = @_;
|
|
|
92 my $self = $caller->SUPER::new(@args);
|
|
|
93
|
|
|
94 my ($feature,$location) = $self->_rearrange([qw(PARENT LOC)],@args);
|
|
|
95
|
|
|
96 if( !defined $feature || !ref $feature || !$feature->isa('Bio::SeqFeatureI') ) {
|
|
|
97 $self->throw("Must have a parent feature, not a [$feature]");
|
|
|
98 }
|
|
|
99
|
|
|
100 if( $feature->isa("Bio::SeqFeature::PositionProxy") ) {
|
|
|
101 $feature = $feature->parent();
|
|
|
102 }
|
|
|
103
|
|
|
104 if( !defined $location || !ref $location || !$location->isa('Bio::LocationI') ) {
|
|
|
105 $self->throw("Must have a location, not a [$location]");
|
|
|
106 }
|
|
|
107
|
|
|
108
|
|
|
109 return $self;
|
|
|
110 }
|
|
|
111
|
|
|
112
|
|
|
113 =head2 location
|
|
|
114
|
|
|
115 Title : location
|
|
|
116 Usage : my $location = $seqfeature->location()
|
|
|
117 Function: returns a location object suitable for identifying location
|
|
|
118 of feature on sequence or parent feature
|
|
|
119 Returns : Bio::LocationI object
|
|
|
120 Args : none
|
|
|
121
|
|
|
122
|
|
|
123 =cut
|
|
|
124
|
|
|
125 sub location {
|
|
|
126 my($self, $value ) = @_;
|
|
|
127
|
|
|
128 if (defined($value)) {
|
|
|
129 unless (ref($value) and $value->isa('Bio::LocationI')) {
|
|
|
130 $self->throw("object $value pretends to be a location but ".
|
|
|
131 "does not implement Bio::LocationI");
|
|
|
132 }
|
|
|
133 $self->{'_location'} = $value;
|
|
|
134 }
|
|
|
135 elsif (! $self->{'_location'}) {
|
|
|
136 # guarantees a real location object is returned every time
|
|
|
137 $self->{'_location'} = Bio::Location::Simple->new();
|
|
|
138 }
|
|
|
139 return $self->{'_location'};
|
|
|
140 }
|
|
|
141
|
|
|
142
|
|
|
143 =head2 parent
|
|
|
144
|
|
|
145 Title : parent
|
|
|
146 Usage : my $sf = $proxy->parent()
|
|
|
147 Function: returns the seqfeature parent of this proxy
|
|
|
148 Returns : Bio::SeqFeatureI object
|
|
|
149 Args : none
|
|
|
150
|
|
|
151
|
|
|
152 =cut
|
|
|
153
|
|
|
154 sub parent {
|
|
|
155 my($self, $value ) = @_;
|
|
|
156
|
|
|
157 if (defined($value)) {
|
|
|
158 unless (ref($value) and $value->isa('Bio::SeqFeatureI')) {
|
|
|
159 $self->throw("object $value pretends to be a location but ".
|
|
|
160 "does not implement Bio::SeqFeatureI");
|
|
|
161 }
|
|
|
162 $self->{'_parent'} = $value;
|
|
|
163 }
|
|
|
164
|
|
|
165 return $self->{'_parent'};
|
|
|
166 }
|
|
|
167
|
|
|
168
|
|
|
169
|
|
|
170 =head2 start
|
|
|
171
|
|
|
172 Title : start
|
|
|
173 Usage : $start = $feat->start
|
|
|
174 $feat->start(20)
|
|
|
175 Function: Get
|
|
|
176 Returns : integer
|
|
|
177 Args : none
|
|
|
178
|
|
|
179
|
|
|
180 =cut
|
|
|
181
|
|
|
182 sub start {
|
|
|
183 my ($self,$value) = @_;
|
|
|
184 return $self->location->start($value);
|
|
|
185 }
|
|
|
186
|
|
|
187 =head2 end
|
|
|
188
|
|
|
189 Title : end
|
|
|
190 Usage : $end = $feat->end
|
|
|
191 $feat->end($end)
|
|
|
192 Function: get
|
|
|
193 Returns : integer
|
|
|
194 Args : none
|
|
|
195
|
|
|
196
|
|
|
197 =cut
|
|
|
198
|
|
|
199 sub end {
|
|
|
200 my ($self,$value) = @_;
|
|
|
201 return $self->location->end($value);
|
|
|
202 }
|
|
|
203
|
|
|
204 =head2 length
|
|
|
205
|
|
|
206 Title : length
|
|
|
207 Usage :
|
|
|
208 Function:
|
|
|
209 Example :
|
|
|
210 Returns :
|
|
|
211 Args :
|
|
|
212
|
|
|
213
|
|
|
214 =cut
|
|
|
215
|
|
|
216 sub length {
|
|
|
217 my ($self) = @_;
|
|
|
218 return $self->end - $self->start() + 1;
|
|
|
219 }
|
|
|
220
|
|
|
221 =head2 strand
|
|
|
222
|
|
|
223 Title : strand
|
|
|
224 Usage : $strand = $feat->strand()
|
|
|
225 $feat->strand($strand)
|
|
|
226 Function: get/set on strand information, being 1,-1 or 0
|
|
|
227 Returns : -1,1 or 0
|
|
|
228 Args : none
|
|
|
229
|
|
|
230
|
|
|
231 =cut
|
|
|
232
|
|
|
233 sub strand {
|
|
|
234 my ($self,$value) = @_;
|
|
|
235 return $self->location->strand($value);
|
|
|
236 }
|
|
|
237
|
|
|
238
|
|
|
239 =head2 attach_seq
|
|
|
240
|
|
|
241 Title : attach_seq
|
|
|
242 Usage : $sf->attach_seq($seq)
|
|
|
243 Function: Attaches a Bio::Seq object to this feature. This
|
|
|
244 Bio::Seq object is for the *entire* sequence: ie
|
|
|
245 from 1 to 10000
|
|
|
246 Example :
|
|
|
247 Returns : TRUE on success
|
|
|
248 Args :
|
|
|
249
|
|
|
250
|
|
|
251 =cut
|
|
|
252
|
|
|
253 sub attach_seq {
|
|
|
254 my ($self, $seq) = @_;
|
|
|
255
|
|
|
256 if ( !defined $seq || !ref $seq || ! $seq->isa("Bio::PrimarySeqI") ) {
|
|
|
257 $self->throw("Must attach Bio::PrimarySeqI objects to SeqFeatures");
|
|
|
258 }
|
|
|
259
|
|
|
260 $self->{'_gsf_seq'} = $seq;
|
|
|
261
|
|
|
262 # attach to sub features if they want it
|
|
|
263
|
|
|
264 foreach my $sf ( $self->sub_SeqFeature() ) {
|
|
|
265 if ( $sf->can("attach_seq") ) {
|
|
|
266 $sf->attach_seq($seq);
|
|
|
267 }
|
|
|
268 }
|
|
|
269 return 1;
|
|
|
270 }
|
|
|
271
|
|
|
272 =head2 seq
|
|
|
273
|
|
|
274 Title : seq
|
|
|
275 Usage : $tseq = $sf->seq()
|
|
|
276 Function: returns the truncated sequence (if there) for this
|
|
|
277 Example :
|
|
|
278 Returns : sub seq on attached sequence bounded by start & end
|
|
|
279 Args : none
|
|
|
280
|
|
|
281
|
|
|
282 =cut
|
|
|
283
|
|
|
284 sub seq {
|
|
|
285 my ($self, $arg) = @_;
|
|
|
286
|
|
|
287 if ( defined $arg ) {
|
|
|
288 $self->throw("Calling SeqFeature::PositionProxy->seq with an argument. You probably want attach_seq");
|
|
|
289 }
|
|
|
290
|
|
|
291 if ( ! exists $self->{'_gsf_seq'} ) {
|
|
|
292 return undef;
|
|
|
293 }
|
|
|
294
|
|
|
295 # assumming our seq object is sensible, it should not have to yank
|
|
|
296 # the entire sequence out here.
|
|
|
297
|
|
|
298 my $seq = $self->{'_gsf_seq'}->trunc($self->start(), $self->end());
|
|
|
299
|
|
|
300
|
|
|
301 if ( $self->strand == -1 ) {
|
|
|
302 $seq = $seq->revcom;
|
|
|
303 }
|
|
|
304
|
|
|
305 return $seq;
|
|
|
306 }
|
|
|
307
|
|
|
308 =head2 entire_seq
|
|
|
309
|
|
|
310 Title : entire_seq
|
|
|
311 Usage : $whole_seq = $sf->entire_seq()
|
|
|
312 Function: gives the entire sequence that this seqfeature is attached to
|
|
|
313 Example :
|
|
|
314 Returns :
|
|
|
315 Args :
|
|
|
316
|
|
|
317
|
|
|
318 =cut
|
|
|
319
|
|
|
320 sub entire_seq {
|
|
|
321 my ($self) = @_;
|
|
|
322
|
|
|
323 return undef unless exists($self->{'_gsf_seq'});
|
|
|
324 return $self->{'_gsf_seq'};
|
|
|
325 }
|
|
|
326
|
|
|
327
|
|
|
328 =head2 seqname
|
|
|
329
|
|
|
330 Title : seqname
|
|
|
331 Usage : $obj->seq_id($newval)
|
|
|
332 Function: There are many cases when you make a feature that you
|
|
|
333 do know the sequence name, but do not know its actual
|
|
|
334 sequence. This is an attribute such that you can store
|
|
|
335 the seqname.
|
|
|
336
|
|
|
337 This attribute should *not* be used in GFF dumping, as
|
|
|
338 that should come from the collection in which the seq
|
|
|
339 feature was found.
|
|
|
340 Returns : value of seqname
|
|
|
341 Args : newvalue (optional)
|
|
|
342
|
|
|
343
|
|
|
344 =cut
|
|
|
345
|
|
|
346 sub seqname {
|
|
|
347 my ($obj,$value) = @_;
|
|
|
348 if ( defined $value ) {
|
|
|
349 $obj->{'_gsf_seqname'} = $value;
|
|
|
350 }
|
|
|
351 return $obj->{'_gsf_seqname'};
|
|
|
352 }
|
|
|
353
|
|
|
354
|
|
|
355
|
|
|
356 =head2 Proxies
|
|
|
357
|
|
|
358 These functions chain back to the parent for all non sequence related stuff.
|
|
|
359
|
|
|
360
|
|
|
361 =cut
|
|
|
362
|
|
|
363 =head2 primary_tag
|
|
|
364
|
|
|
365 Title : primary_tag
|
|
|
366 Usage : $tag = $feat->primary_tag()
|
|
|
367 Function: Returns the primary tag for a feature,
|
|
|
368 eg 'exon'
|
|
|
369 Returns : a string
|
|
|
370 Args : none
|
|
|
371
|
|
|
372
|
|
|
373 =cut
|
|
|
374
|
|
|
375 sub primary_tag{
|
|
|
376 my ($self,@args) = @_;
|
|
|
377
|
|
|
378 return $self->parent->primary_tag();
|
|
|
379 }
|
|
|
380
|
|
|
381 =head2 source_tag
|
|
|
382
|
|
|
383 Title : source_tag
|
|
|
384 Usage : $tag = $feat->source_tag()
|
|
|
385 Function: Returns the source tag for a feature,
|
|
|
386 eg, 'genscan'
|
|
|
387 Returns : a string
|
|
|
388 Args : none
|
|
|
389
|
|
|
390
|
|
|
391 =cut
|
|
|
392
|
|
|
393 sub source_tag{
|
|
|
394 my ($self) = @_;
|
|
|
395
|
|
|
396 return $self->parent->source_tag();
|
|
|
397 }
|
|
|
398
|
|
|
399
|
|
|
400 =head2 has_tag
|
|
|
401
|
|
|
402 Title : has_tag
|
|
|
403 Usage : $tag_exists = $self->has_tag('some_tag')
|
|
|
404 Function:
|
|
|
405 Returns : TRUE if the specified tag exists, and FALSE otherwise
|
|
|
406 Args :
|
|
|
407
|
|
|
408
|
|
|
409 =cut
|
|
|
410
|
|
|
411 sub has_tag{
|
|
|
412 my ($self,$tag) = @_;
|
|
|
413
|
|
|
414 return $self->parent->has_tag($tag);
|
|
|
415 }
|
|
|
416
|
|
|
417 =head2 each_tag_value
|
|
|
418
|
|
|
419 Title : each_tag_value
|
|
|
420 Usage : @values = $self->each_tag_value('some_tag')
|
|
|
421 Function:
|
|
|
422 Returns : An array comprising the values of the specified tag.
|
|
|
423 Args :
|
|
|
424
|
|
|
425
|
|
|
426 =cut
|
|
|
427
|
|
|
428 sub each_tag_value {
|
|
|
429 my ($self,$tag) = @_;
|
|
|
430
|
|
|
431 return $self->parent->each_tag_value($tag);
|
|
|
432 }
|
|
|
433
|
|
|
434 =head2 all_tags
|
|
|
435
|
|
|
436 Title : all_tags
|
|
|
437 Usage : @tags = $feat->all_tags()
|
|
|
438 Function: gives all tags for this feature
|
|
|
439 Returns : an array of strings
|
|
|
440 Args : none
|
|
|
441
|
|
|
442
|
|
|
443 =cut
|
|
|
444
|
|
|
445 sub all_tags{
|
|
|
446 my ($self) = @_;
|
|
|
447
|
|
|
448 return $self->parent->all_tags();
|
|
|
449 }
|
