Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 429 lines (350 sloc) 14.744 kb
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
1 =head1 SeqCanvasFeature.pm
2
3 =head2 AUTHORS
4
5 Mark Wilkinson (mwilkinson@gene.pbi.nrc.ca)
47543837 » mwilkinson
2002-06-03 removed all copyright notices from gui software written by Dave and I…
6
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
7
8 =head2 DISCLAIMER
9
10 Anyone who intends to use and uses this software and code acknowledges and
11 agrees to the following: The National Research Council of Canada (herein "NRC")
12 disclaims any warranties, expressed, implied, or statutory, of any kind or
13 nature with respect to the software, including without limitation any warranty
14 or merchantability or fitness for a particular purpose. NRC shall not be liable
15 in any event for any damages, whether direct or indirect,
16 consequential or incidental, arising from the use of the software.
17
18 =head2 SYNOPSIS
19
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
20 Should not be used (and really has no use) outside of SeqCanvas.
21
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
22
23 =head2 DESCRIPTION and ACKNOWLEDGEMENTS
24
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
25 Essentially, SeqCanvasFeatures encapsulate all the things
26 that SeqCanvas needs to know about a feature in order to map it. This includes both
27 the BioPerl feature itself, as well as the offset, and colour.
28
29 In addition, SeqCanvasFeature has the ability to rip itself apart into its constituent
30 transcripts and exons (if present). Thus there are only two types of SCF's: 'Gene', and
31 'Generic'. "generic" features are alawys called by a simple ->_draw. "Gene" features
32 are pulled apart with sub-features created on-the-fly in this module, and then mapped onto
33 both the finished and draft canvas.
34
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
35
36 =head2 CONTACT
37
38 Mark Wilkinson (mwilkinson@gene.pbi.nrc.ca)
39
40 =cut
41
42
43 package Bio::Tk::SeqCanvasFeature;
44
45 use strict;
46 use Carp;
47 use vars qw($AUTOLOAD);
48
49 {
50 #Encapsulated class data
51
52 #___________________________________________________________
53 #ATTRIBUTES
54 my %_attr_data = # DEFAULT ACCESSIBILITY
55 (
56 SeqCanvas => [undef, 'read/write'],
57 Feature => [undef, 'read/write'], # the actual bioperl Feature object
58 offset => [undef, 'read/write'], # offset from whichever axis it is mapped to
59 color => [undef, 'read/write'], # duh
60 canvas_name => [undef, 'read/write'], # draft or finished
61 canvas => [undef, 'read/write'], # the canvas widget reference
62 map => [undef, 'read/write'], # the map widget reference
63 widget => [undef, 'read/write'], # the widget itself
64 FID => [undef, 'read/write'], # the FeatureID, which is the position of that feature in the list of mapped features.
65 label => [undef, 'read/write'], # which tag should be used as the label fo the mapped widget
66 tags => [[], 'read/write'],
67 transcript_color => ["#dddddd", 'read/write'], # transcripts are grey
68 parent_transcript=> [undef, 'read/write'], # sub-gene objects need to know their parent transcript
69 parent_gene => [undef, 'read/write'], # sub-gene objects need to know their parent gene
70
71 );
72
73 #_____________________________________________________________
74 #METHODS, to operate on encapsulated class data
75 my $_nextid;
76 # Is a specified object attribute accessible in a given mode
77 sub _accessible {
78 my ($self, $attr, $mode) = @_;
79 $_attr_data{$attr}[1] =~ /$mode/
80 }
81
82 # Classwide default value for a specified object attribute
83 sub _default_for {
84 my ($self, $attr) = @_;
85 $_attr_data{$attr}[0];
86 }
87
88 # List of names of all specified object attributes
89 sub _standard_keys {
90 keys %_attr_data;
91 }
92
93 sub next_id {
94 unless ($_nextid){$_nextid = 0}
95 return $_nextid++;
96 }
97 }
98
99 sub AUTOLOAD {
100 no strict "refs";
101 my ($self, $newval) = @_;
102
103 $AUTOLOAD =~ /.*::(\w+)/;
104
105 my $attr=$1;
106 if ($self->_accessible($attr,'write')) {
107
108 *{$AUTOLOAD} = sub {
109 if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
110 return $_[0]->{$attr};
111 }; ### end of created subroutine
112
113 ### this is called first time only
114 if (defined $newval) {
115 $self->{$attr} = $newval
116 }
117 return $self->{$attr};
118
119 } elsif ($self->_accessible($attr,'read')) {
120
121 *{$AUTOLOAD} = sub {
122 return $_[0]->{$attr} }; ### end of created subroutine
123 return $self->{$attr} }
124
125
126 # Must have been a mistake then...
127 croak "No such method: $AUTOLOAD";
128 }
129
130
131 sub new {
132 my ($caller, %args) = @_;
133
134 my $caller_is_obj = ref($caller);
135 my $class = $caller_is_obj || $caller;
136
137 my $self = bless {}, $class;
138
139 foreach my $attrname ( $self->_standard_keys ) {
140 if (exists $args{$attrname}) {
141 $self->{$attrname} = $args{$attrname} }
142 elsif ($caller_is_obj) {
143 $self->{$attrname} = $caller->{$attrname} }
144 else {
145 $self->{$attrname} = $self->_default_for($attrname) }
146 }
147 my $id = $self->next_id;
148 $self->FID("FID$id");
149 return $self;
150
151 }
152
153 sub drawThyself {
154 my ($self, @tags) = @_;
155 my ($genes, $transcripts, $exons, $promotors, $polyAs);
156 my $map = $self->canvas_name;
157 if ($map eq "draft"){$self->_drawThyselfOnDraft}
158 else {($genes, $transcripts, $exons, $promotors, $polyAs) = $self->_drawThyselfOnFinished} # this is necessary because the finished canvas must unpack the
159 # feature object and draw its transcripts
160 return ($genes, $transcripts, $exons, $promotors, $polyAs); # for draft objects, these are all empty
161 }
162
163 sub _drawThyselfOnDraft {
164 my ($self) = @_;
165 # draft features know enough about themselves to draw directly with no further parsing.
166 $self->_draw; # this both draws the widget, and encapsulates the widget into the SCF object
167 }
168
169
170 sub _drawThyselfOnFinished {
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
171 my ($SCF_GENE) = @_;
172 # SeqCanvasFeatures coming into this routine should be exclusively one of the following:
173 # primary_tag = "gene"
174 # $feature->can('transcripts') ----> i.e. a GeneStructureI compliant feature
175 # they do NOT have a color,
176 # nor do they have an offset yet.
177 # they must be 'unpacked' into their constituent parts, transcripts, exons, etc. and then mapped
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
178
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
179 my $SeqCanvas = $SCF_GENE->SeqCanvas; # this is the parent window into which we are mapping this widget
180 # which is needed to get color and offset information
181 my (@genes, @transcripts, @exons, @promotors, @polyAs, @blank_transcripts);
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
182
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
183 push @genes, $SCF_GENE; # put top-level gene SCF into the list of mapped objects that will be passed back for binding
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
184
185 # starting with the highest level object - the entire gene
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
186 $SCF_GENE->offset($SeqCanvas->current_offsets->{"gene"}); # assign standard colors and offsets
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
187 $SCF_GENE->color($SeqCanvas->current_colors->{"gene"});
188 # DRAW GENE-LEVEL OBJECT
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
189 $SCF_GENE->_draw; # this also encapsulates the widget itself into the SCF object
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
190
191 #FIND TRANSCRIPT OBJECTS
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
192 if ($SCF_GENE->Feature->can("transcripts")) { # don't do the rest of this routine if it is not a GeneStructureI compliant object.
193 my $model = 0; # ordinal number of transcript (needed for offset calculation)
194 foreach my $transcript ($SCF_GENE->Feature->transcripts) { # take each transcript
195 ++$model;
1e096c99 » mwilkinson
2002-01-18 fixed one more problem with seqcanvas and its features recolouring on…
196
197 my $SCF_transcript = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $SeqCanvas,
fa761718 » dblock
2001-10-23 Changes to allow bug-free creation/deletion of GeneStructure objects
198 Feature => $transcript, # this fills all of the FeatureI methods
199 canvas_name => 'finished',
200 canvas => $SeqCanvas->FinishedCanvas,
201 map => $SeqCanvas->FinishedMap,
202 label => $SeqCanvas->label,
203 ); # create a new SeqcanvasFeature object for this feature
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
204 # it is assigned an FID during creation
fa761718 » dblock
2001-10-23 Changes to allow bug-free creation/deletion of GeneStructure objects
205 $SCF_transcript->offset($SeqCanvas->current_offsets->{"transcript$model"}); # assign standard color and offset according to ordinal number
206 $SCF_transcript->color($SCF_transcript->transcript_color); # get the transcript default color
207 $SCF_transcript->_draw;
1e096c99 » mwilkinson
2002-01-18 fixed one more problem with seqcanvas and its features recolouring on…
208 $SCF_transcript->parent_gene($SCF_GENE);
209 push @transcripts, $SCF_transcript;
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
210
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
211 foreach my $exon ($transcript->exons) {
1e096c99 » mwilkinson
2002-01-18 fixed one more problem with seqcanvas and its features recolouring on…
212
213 my $SCF = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $SeqCanvas,
214 Feature => $exon, # this fills all of the FeatureI methods
215 canvas_name => 'finished',
216 canvas => $SeqCanvas->FinishedCanvas,
217 map => $SeqCanvas->FinishedMap,
218 label => $SeqCanvas->label,
219 ); # create a new SeqcanvasFeature object for this feature
220 # it is assigned an FID during creation
221 $SCF->offset($SeqCanvas->current_offsets->{"transcript$model"}); # assign standard offset according to ordinal number
222 $SCF->color($SeqCanvas->current_colors->{$SCF->source}); # assign color according to the source tag
223 $SCF->_draw;
224 $SCF->parent_gene($SCF_GENE);
225 $SCF->parent_transcript($SCF_transcript);
226
227 push @exons, $SCF;
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
228 }
229 foreach my $promotor ($transcript->promoters) {
1e096c99 » mwilkinson
2002-01-18 fixed one more problem with seqcanvas and its features recolouring on…
230 my $SCF = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $SeqCanvas,
231 Feature => $promotor, # this fills all of the FeatureI methods
232 canvas_name => 'finished',
233 canvas => $SeqCanvas->FinishedCanvas,
234 map => $SeqCanvas->FinishedMap,
235 label => $SeqCanvas->label,
236 ); # create a new SeqcanvasFeature object for this feature
237 # it is assigned an FID during creation
238 $SCF->offset($SeqCanvas->current_offsets->{"transcript$model"}); # assign standard offset according to ordinal number
239 $SCF->color($SeqCanvas->current_colors->{$SCF->source}); # assign color by source tag
240 $SCF->_draw;
241 $SCF->parent_gene($SCF_GENE);
242 $SCF->parent_transcript($SCF_transcript);
243 push @promotors, $SCF;
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
244 }
245 if ($transcript->poly_A_site) {
246 my $polyA = $transcript->poly_A_site;
247 my $SCF = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $SeqCanvas,
248 Feature => $polyA, # this fills all of the FeatureI methods
249 canvas_name => 'finished',
250 canvas => $SeqCanvas->FinishedCanvas,
251 map => $SeqCanvas->FinishedMap,
252 label => $SeqCanvas->label,
253 ); # create a new SeqcanvasFeature object for this feature
254 # it is assigned an FID during creation
255 $SCF->offset($SeqCanvas->current_offsets->{"transcript$model"}); # assign standard offset according to ordinal number
256 $SCF->color($SeqCanvas->current_colors->{$SCF->source}); # assign color by source tag
257 $SCF->_draw;
258 $SCF->parent_gene($SCF_GENE);
fa761718 » dblock
2001-10-23 Changes to allow bug-free creation/deletion of GeneStructure objects
259 $SCF->parent_transcript($SCF_transcript);
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
260 push @polyAs, $SCF;
261
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
262 }
263 } # end of foreach my transcripts
264 } # end of if self can transripts
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
265
266 return (\@genes, \@transcripts, \@exons, \@promotors, \@polyAs);
267 }
268
269
270 sub _draw {
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
271 my ($self) = @_;
272 my $map = $self->map;
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
273 my $canvas = $self->canvas;
274 my $FID = $self->FID;
275 my $color = $self->color;
276 my $label;
4f2d0603 » mwilkinson
2003-04-22 various changes to get rid of t-test non-critical errors
277 if ($self->label && $self->has_tag($self->label)){
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
278 if ($self->Feature->strand == -1) {
279 $self->offset($self->offset - 5);
280 }
281 ($label) = ($self->label)?$self->each_tag_value($self->label):undef; # set the label if it is required and present
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
282 } else {
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
283 $label = undef;
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
284 }
15458695 » dblock
2001-10-15 Fixed the annoying display bug where reverse strand genes would have …
285 my $offset = $self->offset;
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
286 my $start = $self->start;
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
287 my $end = $self->end;
288 my $strand = $self->strand;
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
289 my @tags = $self->_parse_feature_info;
290 my @coords; my $widget;
291
292 if ($strand =~ /\-/) {
293 push @coords, [$end, $start];
294 if (!$label){ # if no labels, or if this feature doesn't have the label then map without labelling
295 $widget = $map->MapObject(\@coords, '-ataxis' => $offset,
296 '-color' => $color, '-tags' => \@tags);
297 } else {
298 $widget = $map->MapObject(\@coords, '-ataxis' => $offset, '-label' => $label, '-labelcolor' => $color,
299 '-color' => $color, '-tags' => \@tags);
300 }
301
302 } else {
303 push @coords, [$start, $end];
304 if (!$label){
305 $widget = $map->MapObject(\@coords, '-ataxis' => -$offset,
306 '-color' => $color, '-tags' => \@tags);
307 } else {
308 $widget = $map->MapObject(\@coords, '-ataxis' => -$offset, '-label' => $label, '-labelcolor' => $color,
309 '-color' => $color, '-tags' => \@tags);
310 }
311 }
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
312 $self->widget($widget); # dont forget to put a reference to the widget itself into the SCF
b20d4bf1 » mwilkinson
2001-10-03 Added ability to re-cast Generic features into a variety of GeneStruc…
313 }
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
314
315 sub _parse_feature_info {
316 my ($self) = @_;
317 my @tags;
318 my $start = $self->start;
319 my $stop = $self->end;
320 my $offset = $self->offset;
321 my $source = $self->source_tag;
322 my $type = $self->primary_tag;
323 my $strand = $self->strand;
324 my $whichmap = $self->canvas_name;
b53fed1c » mwilkinson
2002-01-18 added sanity checking to SeqCanvasfeatures, and changed the error mes…
325 my $ObjectType = ref($self->Feature);
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
326 my $FID = $self->FID;
327 $strand =~ s/\+/1/; # these change GFF format strand designations into BioPerl Seq object strand desig.
328 $strand =~ s/-$/-1/; # But really... BioPerl should adopt GFF formats one day - The GFF designations are
329 $strand =~ s/\./0/; # much more intuitive (IMHO)
330 if ($self->has_tag("id")){push @tags, "DB_ID " . $self->each_tag_value("id")} # this is to 'link' this widget to an an external database if desired.
331 push @tags, $FID; # assign that ID to this on-screen widget
332 push @tags, "Source $source"; # push the source so that we can retrieve the offset and color later if necessary
333 push @tags, "Strand $strand";
334 push @tags, "Type $type"; # this holds the info about what type of Feature it is... comes from Primary tag...
335 push @tags, "Canvas $whichmap"; # let the widget know which map it is sitting on
336 push @tags, "_SC_start $start";
337 push @tags, "_SC_stop $stop";
338 push @tags, "_SC_offset $offset";
b53fed1c » mwilkinson
2002-01-18 added sanity checking to SeqCanvasfeatures, and changed the error mes…
339 push @tags, "ObjectType $ObjectType";
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
340 push @tags, "M_Ftr"; # this is a generic tag to indicate that this is a mapped feature - used to obtain the bounding box for mapped features which then sets the scrollregion
b53fed1c » mwilkinson
2002-01-18 added sanity checking to SeqCanvasfeatures, and changed the error mes…
341 return (@tags);
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
342 }
343
344
345
346 # for partial SeqFeatureI compatability
347 sub start {
348 my ($self) = @_;
349 return $self->Feature->start;
350 }
351
352 sub end {
353 my ($self) = @_;
354 return $self->Feature->end;
355 }
356
357 sub stop {
358 my ($self) = @_;
359 return $self->Feature->end;
360 }
361
362 sub source {
363 my ($self) = @_;
364 return $self->Feature->source_tag;
365 }
366
367 sub source_tag {
368 my ($self) = @_;
369 return $self->Feature->source_tag;
370 }
371
372 sub primary_tag {
373 my ($self) = @_;
374 return $self->Feature->primary_tag;
375 }
376
377 sub location {
378 my ($self) = @_;
379 return $self->Feature->location;
380 }
381
382 sub length {
383 my ($self) = @_;
384 return $self->Feature->length;
385 }
386
387 sub strand {
388 my ($self) = @_;
389 return $self->Feature->strand;
390 }
391
392 sub score {
393 my ($self) = @_;
394 return $self->Feature->score;
395 }
396
397 sub frame {
398 my ($self) = @_;
399 return $self->Feature->frame;
400 }
401
402 sub sub_SeqFeature {
403 my ($self) = @_;
404 return $self->Feature->sub_SeqFeature;
405 }
406
407 sub has_tag {
408 my ($self, $tag) = @_;
409 return $self->Feature->has_tag($tag);
410 }
411
412 sub each_tag_value {
413 my ($self, $tag) = @_;
414 return $self->Feature->each_tag_value($tag);
415 }
416
417 sub all_tags {
418 my ($self) = @_;
419 return $self->Feature->all_tags;
420 }
421
422 sub gff_string {
423 my ($self, $format) = @_;
424 return $self->Feature->gff_string($format);
425 }
426
4f2d0603 » mwilkinson
2003-04-22 various changes to get rid of t-test non-critical errors
427 sub DESTROY {}
331455be » mwilkinson
2001-07-31 the new version of SeqCanvas that I just committed requires this new …
428
429 1;
Something went wrong with that request. Please try again.