|
0
|
1 package Bio::Graphics::Glyph;
|
|
|
2 use GD;
|
|
|
3
|
|
|
4 use strict;
|
|
|
5 use Carp 'croak';
|
|
|
6 use constant BUMP_SPACING => 2; # vertical distance between bumped glyphs
|
|
|
7
|
|
|
8
|
|
|
9 my %LAYOUT_COUNT;
|
|
|
10
|
|
|
11 # the CM1 and CM2 constants control the size of the hash used to
|
|
|
12 # detect collisions.
|
|
|
13 use constant CM1 => 200; # big bin, x axis
|
|
|
14 use constant CM2 => 50; # big bin, y axis
|
|
|
15 use constant CM3 => 50; # small bin, x axis
|
|
|
16 use constant CM4 => 50; # small bin, y axis
|
|
|
17
|
|
|
18 use constant QUILL_INTERVAL => 8; # number of pixels between Jim Kent style intron "quills"
|
|
|
19
|
|
|
20 # a bumpable graphical object that has bumpable graphical subparts
|
|
|
21
|
|
|
22 # args: -feature => $feature_object (may contain subsequences)
|
|
|
23 # -factory => $factory_object (called to create glyphs for subsequences)
|
|
|
24 # In this scheme, the factory decides based on stylesheet information what glyph to
|
|
|
25 # draw and what configurations options to us. This allows for heterogeneous tracks.
|
|
|
26 sub new {
|
|
|
27 my $class = shift;
|
|
|
28 my %arg = @_;
|
|
|
29
|
|
|
30 my $feature = $arg{-feature} or die "No feature";
|
|
|
31 my $factory = $arg{-factory} || $class->default_factory;
|
|
|
32 my $level = $arg{-level} || 0;
|
|
|
33 my $flip = $arg{-flip};
|
|
|
34
|
|
|
35 my $self = bless {},$class;
|
|
|
36 $self->{feature} = $feature;
|
|
|
37 $self->{factory} = $factory;
|
|
|
38 $self->{level} = $level;
|
|
|
39 $self->{flip}++ if $flip;
|
|
|
40 $self->{top} = 0;
|
|
|
41
|
|
|
42 my @subglyphs;
|
|
|
43 my @subfeatures = $self->subseq($feature);
|
|
|
44
|
|
|
45 if (@subfeatures) {
|
|
|
46
|
|
|
47 # dynamic glyph resolution
|
|
|
48 @subglyphs = map { $_->[0] }
|
|
|
49 sort { $a->[1] <=> $b->[1] }
|
|
|
50 map { [$_, $_->left ] }
|
|
|
51 $factory->make_glyph($level+1,@subfeatures);
|
|
|
52
|
|
|
53 $self->{parts} = \@subglyphs;
|
|
|
54 }
|
|
|
55
|
|
|
56 my ($start,$stop) = ($self->start, $self->stop);
|
|
|
57 if (defined $start && defined $stop) {
|
|
|
58 ($start,$stop) = ($stop,$start) if $start > $stop; # sheer paranoia
|
|
|
59 # the +1 here is critical for allowing features to meet nicely at nucleotide resolution
|
|
|
60 my ($left,$right) = $factory->map_pt($start,$stop+1);
|
|
|
61 $self->{left} = $left;
|
|
|
62 $self->{width} = $right - $left + 1;
|
|
|
63 }
|
|
|
64 if (@subglyphs) {
|
|
|
65 my $l = $subglyphs[0]->left;
|
|
|
66 $self->{left} = $l if !defined($self->{left}) || $l < $self->{left};
|
|
|
67 my $right = (
|
|
|
68 sort { $b<=>$a }
|
|
|
69 map {$_->right} @subglyphs)[0];
|
|
|
70 my $w = $right - $self->{left} + 1;
|
|
|
71 $self->{width} = $w if !defined($self->{width}) || $w > $self->{width};
|
|
|
72 }
|
|
|
73
|
|
|
74 $self->{point} = $arg{-point} ? $self->height : undef;
|
|
|
75 #Handle glyphs that don't actually fill their space, but merely mark a point.
|
|
|
76 #They need to have their collision bounds altered. We will (for now)
|
|
|
77 #hard code them to be in the center of their feature.
|
|
|
78 # note: this didn't actually seem to work properly, all features were aligned on
|
|
|
79 # their right edges. It works to do it in individual point-like glyphs such as triangle.
|
|
|
80 # if($self->option('point')){
|
|
|
81 # my ($left,$right) = $factory->map_pt($self->start,$self->stop);
|
|
|
82 # my $center = int(($left+$right)/2 + 0.5);
|
|
|
83
|
|
|
84 # $self->{width} = $self->height;
|
|
|
85 # $self->{left} = $center - ($self->{width});
|
|
|
86 # $self->{right} = $center + ($self->{width});
|
|
|
87 # }
|
|
|
88
|
|
|
89 return $self;
|
|
|
90 }
|
|
|
91
|
|
|
92 sub parts {
|
|
|
93 my $self = shift;
|
|
|
94 return unless $self->{parts};
|
|
|
95 return wantarray ? @{$self->{parts}} : $self->{parts};
|
|
|
96 }
|
|
|
97
|
|
|
98 sub feature { shift->{feature} }
|
|
|
99 sub factory { shift->{factory} }
|
|
|
100 sub panel { shift->factory->panel }
|
|
|
101 sub point { shift->{point} }
|
|
|
102 sub scale { shift->factory->scale }
|
|
|
103 sub start {
|
|
|
104 my $self = shift;
|
|
|
105 return $self->{start} if exists $self->{start};
|
|
|
106 $self->{start} = $self->{flip} ? $self->panel->end + 1 - $self->{feature}->end : $self->{feature}->start;
|
|
|
107
|
|
|
108 # handle the case of features whose endpoints are undef
|
|
|
109 # (this happens with wormbase clones where one or more clone end is not defined)
|
|
|
110 # in this case, we set the start to one minus the beginning of the panel
|
|
|
111 $self->{start} = $self->panel->offset - 1 unless defined $self->{start};
|
|
|
112
|
|
|
113 return $self->{start};
|
|
|
114 }
|
|
|
115 sub stop {
|
|
|
116 my $self = shift;
|
|
|
117 return $self->{stop} if exists $self->{stop};
|
|
|
118 $self->{stop} = $self->{flip} ? $self->panel->end + 1 - $self->{feature}->start : $self->{feature}->end;
|
|
|
119
|
|
|
120 # handle the case of features whose endpoints are undef
|
|
|
121 # (this happens with wormbase clones where one or more clone end is not defined)
|
|
|
122 # in this case, we set the start to one plus the end of the panel
|
|
|
123 $self->{stop} = $self->panel->offset + $self->panel->length + 1 unless defined $self->{stop};
|
|
|
124
|
|
|
125 return $self->{stop}
|
|
|
126 }
|
|
|
127 sub end { shift->stop }
|
|
|
128 sub length { my $self = shift; $self->stop - $self->start };
|
|
|
129 sub score {
|
|
|
130 my $self = shift;
|
|
|
131 return $self->{score} if exists $self->{score};
|
|
|
132 return $self->{score} = ($self->{feature}->score || 0);
|
|
|
133 }
|
|
|
134 sub strand {
|
|
|
135 my $self = shift;
|
|
|
136 return $self->{strand} if exists $self->{strand};
|
|
|
137 return $self->{strand} = ($self->{feature}->strand || 0);
|
|
|
138 }
|
|
|
139 sub map_pt { shift->{factory}->map_pt(@_) }
|
|
|
140 sub map_no_trunc { shift->{factory}->map_no_trunc(@_) }
|
|
|
141
|
|
|
142 # add a feature (or array ref of features) to the list
|
|
|
143 sub add_feature {
|
|
|
144 my $self = shift;
|
|
|
145 my $factory = $self->factory;
|
|
|
146 for my $feature (@_) {
|
|
|
147 if (ref $feature eq 'ARRAY') {
|
|
|
148 $self->add_group(@$feature);
|
|
|
149 } else {
|
|
|
150 push @{$self->{parts}},$factory->make_glyph(0,$feature);
|
|
|
151 }
|
|
|
152 }
|
|
|
153 }
|
|
|
154
|
|
|
155 # link a set of features together so that they bump as a group
|
|
|
156 sub add_group {
|
|
|
157 my $self = shift;
|
|
|
158 my @features = ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_;
|
|
|
159 my $f = Bio::Graphics::Feature->new(
|
|
|
160 -segments=>\@features,
|
|
|
161 -type => 'group'
|
|
|
162 );
|
|
|
163 $self->add_feature($f);
|
|
|
164 }
|
|
|
165
|
|
|
166 sub top {
|
|
|
167 my $self = shift;
|
|
|
168 my $g = $self->{top};
|
|
|
169 $self->{top} = shift if @_;
|
|
|
170 $g;
|
|
|
171 }
|
|
|
172 sub left {
|
|
|
173 my $self = shift;
|
|
|
174 return $self->{left} - $self->pad_left;
|
|
|
175 }
|
|
|
176 sub right {
|
|
|
177 my $self = shift;
|
|
|
178 return $self->left + $self->layout_width - 1;
|
|
|
179 }
|
|
|
180 sub bottom {
|
|
|
181 my $self = shift;
|
|
|
182 $self->top + $self->layout_height - 1;
|
|
|
183 }
|
|
|
184 sub height {
|
|
|
185 my $self = shift;
|
|
|
186 return $self->{height} if exists $self->{height};
|
|
|
187 my $baseheight = $self->option('height'); # what the factory says
|
|
|
188 return $self->{height} = $baseheight;
|
|
|
189 }
|
|
|
190 sub width {
|
|
|
191 my $self = shift;
|
|
|
192 my $g = $self->{width};
|
|
|
193 $self->{width} = shift if @_;
|
|
|
194 $g;
|
|
|
195 }
|
|
|
196 sub layout_height {
|
|
|
197 my $self = shift;
|
|
|
198 return $self->layout;
|
|
|
199 }
|
|
|
200 sub layout_width {
|
|
|
201 my $self = shift;
|
|
|
202 return $self->width + $self->pad_left + $self->pad_right;
|
|
|
203 }
|
|
|
204
|
|
|
205 # returns the rectangle that surrounds the physical part of the
|
|
|
206 # glyph, excluding labels and other "extra" stuff
|
|
|
207 sub calculate_boundaries {return shift->bounds(@_);}
|
|
|
208
|
|
|
209 sub bounds {
|
|
|
210 my $self = shift;
|
|
|
211 my ($dx,$dy) = @_;
|
|
|
212 $dx += 0; $dy += 0;
|
|
|
213 ($dx + $self->{left},
|
|
|
214 $dy + $self->top + $self->pad_top,
|
|
|
215 $dx + $self->{left} + $self->{width} - 1,
|
|
|
216 $dy + $self->bottom - $self->pad_bottom);
|
|
|
217 }
|
|
|
218
|
|
|
219
|
|
|
220 sub box {
|
|
|
221 my $self = shift;
|
|
|
222 return ($self->left,$self->top,$self->right,$self->bottom);
|
|
|
223 }
|
|
|
224
|
|
|
225
|
|
|
226 sub unfilled_box {
|
|
|
227 my $self = shift;
|
|
|
228 my $gd = shift;
|
|
|
229 my ($x1,$y1,$x2,$y2,$fg,$bg) = @_;
|
|
|
230
|
|
|
231 my $linewidth = $self->option('linewidth') || 1;
|
|
|
232
|
|
|
233 unless ($fg) {
|
|
|
234 $fg ||= $self->fgcolor;
|
|
|
235 $fg = $self->set_pen($linewidth,$fg) if $linewidth > 1;
|
|
|
236 }
|
|
|
237
|
|
|
238 unless ($bg) {
|
|
|
239 $bg ||= $self->bgcolor;
|
|
|
240 $bg = $self->set_pen($linewidth,$bg) if $linewidth > 1;
|
|
|
241 }
|
|
|
242
|
|
|
243 # draw a box
|
|
|
244 $gd->rectangle($x1,$y1,$x2,$y2,$fg);
|
|
|
245
|
|
|
246 # if the left end is off the end, then cover over
|
|
|
247 # the leftmost line
|
|
|
248 my ($width) = $gd->getBounds;
|
|
|
249
|
|
|
250 $gd->line($x1,$y1+$linewidth,$x1,$y2-$linewidth,$bg)
|
|
|
251 if $x1 < $self->panel->pad_left;
|
|
|
252
|
|
|
253 $gd->line($x2,$y1+$linewidth,$x2,$y2-$linewidth,$bg)
|
|
|
254 if $x2 > $width - $self->panel->pad_right;
|
|
|
255 }
|
|
|
256
|
|
|
257
|
|
|
258 # return boxes surrounding each part
|
|
|
259 sub boxes {
|
|
|
260 my $self = shift;
|
|
|
261 my ($left,$top) = @_;
|
|
|
262 $top += 0; $left += 0;
|
|
|
263 my @result;
|
|
|
264
|
|
|
265 $self->layout;
|
|
|
266 my @parts = $self->parts;
|
|
|
267 @parts = $self if !@parts && $self->option('box_subparts') && $self->level>0;
|
|
|
268
|
|
|
269 for my $part ($self->parts) {
|
|
|
270 if (eval{$part->feature->primary_tag} eq 'group' or
|
|
|
271 ($part->level == 0 && $self->option('box_subparts'))) {
|
|
|
272 push @result,$part->boxes($left+$self->left+$self->pad_left,$top+$self->top+$self->pad_top);
|
|
|
273 } else {
|
|
|
274 my ($x1,$y1,$x2,$y2) = $part->box;
|
|
|
275 push @result,[$part->feature,$x1,$top+$self->top+$self->pad_top+$y1,
|
|
|
276 $x2,$top+$self->top+$self->pad_top+$y2];
|
|
|
277 }
|
|
|
278 }
|
|
|
279 return wantarray ? @result : \@result;
|
|
|
280 }
|
|
|
281
|
|
|
282 # this should be overridden for labels, etc.
|
|
|
283 # allows glyph to make itself thicker or thinner depending on
|
|
|
284 # domain-specific knowledge
|
|
|
285 sub pad_top {
|
|
|
286 my $self = shift;
|
|
|
287 return 0;
|
|
|
288 }
|
|
|
289 sub pad_bottom {
|
|
|
290 my $self = shift;
|
|
|
291 return 0;
|
|
|
292 }
|
|
|
293 sub pad_left {
|
|
|
294 my $self = shift;
|
|
|
295 return 0;
|
|
|
296 }
|
|
|
297 sub pad_right {
|
|
|
298 my $self = shift;
|
|
|
299 # this shouldn't be necessary
|
|
|
300 my @parts = $self->parts or return 0;
|
|
|
301 my $max = 0;
|
|
|
302 foreach (@parts) {
|
|
|
303 my $pr = $_->pad_right;
|
|
|
304 $max = $pr if $max < $pr;
|
|
|
305 }
|
|
|
306 $max;
|
|
|
307 }
|
|
|
308
|
|
|
309 # move relative to parent
|
|
|
310 sub move {
|
|
|
311 my $self = shift;
|
|
|
312 my ($dx,$dy) = @_;
|
|
|
313 $self->{left} += $dx;
|
|
|
314 $self->{top} += $dy;
|
|
|
315
|
|
|
316 # because the feature parts use *absolute* not relative addressing
|
|
|
317 # we need to move each of the parts horizontally, but not vertically
|
|
|
318 $_->move($dx,0) foreach $self->parts;
|
|
|
319 }
|
|
|
320
|
|
|
321 # get an option
|
|
|
322 sub option {
|
|
|
323 my $self = shift;
|
|
|
324 my $option_name = shift;
|
|
|
325 my $factory = $self->factory;
|
|
|
326 return unless $factory;
|
|
|
327 $factory->option($self,$option_name,@{$self}{qw(partno total_parts)});
|
|
|
328 }
|
|
|
329
|
|
|
330 # set an option globally
|
|
|
331 sub configure {
|
|
|
332 my $self = shift;
|
|
|
333 my $factory = $self->factory;
|
|
|
334 my $option_map = $factory->option_map;
|
|
|
335 while (@_) {
|
|
|
336 my $option_name = shift;
|
|
|
337 my $option_value = shift;
|
|
|
338 ($option_name = lc $option_name) =~ s/^-//;
|
|
|
339 $option_map->{$option_name} = $option_value;
|
|
|
340 }
|
|
|
341 }
|
|
|
342
|
|
|
343 # some common options
|
|
|
344 sub color {
|
|
|
345 my $self = shift;
|
|
|
346 my $color = shift;
|
|
|
347 my $index = $self->option($color);
|
|
|
348 # turn into a color index
|
|
|
349 return $self->factory->translate_color($index) if defined $index;
|
|
|
350 return 0;
|
|
|
351 }
|
|
|
352
|
|
|
353 sub connector {
|
|
|
354 return shift->option('connector',@_);
|
|
|
355 }
|
|
|
356
|
|
|
357 # return value:
|
|
|
358 # 0 no bumping
|
|
|
359 # +1 bump down
|
|
|
360 # -1 bump up
|
|
|
361 sub bump {
|
|
|
362 my $self = shift;
|
|
|
363 return $self->option('bump');
|
|
|
364 }
|
|
|
365
|
|
|
366 # we also look for the "color" option for Ace::Graphics compatibility
|
|
|
367 sub fgcolor {
|
|
|
368 my $self = shift;
|
|
|
369 my $color = $self->option('fgcolor');
|
|
|
370 my $index = defined $color ? $color : $self->option('color');
|
|
|
371 $index = 'black' unless defined $index;
|
|
|
372 $self->factory->translate_color($index);
|
|
|
373 }
|
|
|
374
|
|
|
375 #add for compatibility
|
|
|
376 sub fillcolor {
|
|
|
377 my $self = shift;
|
|
|
378 return $self->bgcolor;
|
|
|
379 }
|
|
|
380
|
|
|
381 # we also look for the "background-color" option for Ace::Graphics compatibility
|
|
|
382 sub bgcolor {
|
|
|
383 my $self = shift;
|
|
|
384 my $bgcolor = $self->option('bgcolor');
|
|
|
385 my $index = defined $bgcolor ? $bgcolor : $self->option('fillcolor');
|
|
|
386 $index = 'white' unless defined $index;
|
|
|
387 $self->factory->translate_color($index);
|
|
|
388 }
|
|
|
389 sub font {
|
|
|
390 my $self = shift;
|
|
|
391 my $font = $self->option('font');
|
|
|
392 unless (UNIVERSAL::isa($font,'GD::Font')) {
|
|
|
393 my $ref = {
|
|
|
394 gdTinyFont => gdTinyFont,
|
|
|
395 gdSmallFont => gdSmallFont,
|
|
|
396 gdMediumBoldFont => gdMediumBoldFont,
|
|
|
397 gdLargeFont => gdLargeFont,
|
|
|
398 gdGiantFont => gdGiantFont};
|
|
|
399 my $gdfont = $ref->{$font} || $font;
|
|
|
400 $self->configure(font=>$gdfont);
|
|
|
401 return $gdfont;
|
|
|
402 }
|
|
|
403 return $font;
|
|
|
404 }
|
|
|
405 sub fontcolor {
|
|
|
406 my $self = shift;
|
|
|
407 my $fontcolor = $self->color('fontcolor');
|
|
|
408 return defined $fontcolor ? $fontcolor : $self->fgcolor;
|
|
|
409 }
|
|
|
410 sub font2color {
|
|
|
411 my $self = shift;
|
|
|
412 my $font2color = $self->color('font2color');
|
|
|
413 return defined $font2color ? $font2color : $self->fgcolor;
|
|
|
414 }
|
|
|
415 sub tkcolor { # "track color"
|
|
|
416 my $self = shift;
|
|
|
417 $self->option('tkcolor') or return;
|
|
|
418 return $self->color('tkcolor')
|
|
|
419 }
|
|
|
420 sub connector_color {
|
|
|
421 my $self = shift;
|
|
|
422 $self->color('connector_color') || $self->fgcolor;
|
|
|
423 }
|
|
|
424
|
|
|
425 sub layout_sort {
|
|
|
426
|
|
|
427 my $self = shift;
|
|
|
428 my $sortfunc;
|
|
|
429
|
|
|
430 my $opt = $self->option("sort_order");
|
|
|
431 if (!$opt) {
|
|
|
432 $sortfunc = eval 'sub { $a->left <=> $b->left }';
|
|
|
433 } elsif (ref $opt eq 'CODE') {
|
|
|
434 $sortfunc = $opt;
|
|
|
435 } elsif ($opt =~ /^sub\s+\{/o) {
|
|
|
436 $sortfunc = eval $opt;
|
|
|
437 } else {
|
|
|
438 # build $sortfunc for ourselves:
|
|
|
439 my @sortbys = split(/\s*\|\s*/o, $opt);
|
|
|
440 $sortfunc = 'sub { ';
|
|
|
441 my $sawleft = 0;
|
|
|
442
|
|
|
443 # not sure I can make this schwartzian transfored
|
|
|
444 for my $sortby (@sortbys) {
|
|
|
445 if ($sortby eq "left" || $sortby eq "default") {
|
|
|
446 $sortfunc .= '($a->left <=> $b->left) || ';
|
|
|
447 $sawleft++;
|
|
|
448 } elsif ($sortby eq "right") {
|
|
|
449 $sortfunc .= '($a->right <=> $b->right) || ';
|
|
|
450 } elsif ($sortby eq "low_score") {
|
|
|
451 $sortfunc .= '($a->score <=> $b->score) || ';
|
|
|
452 } elsif ($sortby eq "high_score") {
|
|
|
453 $sortfunc .= '($b->score <=> $a->score) || ';
|
|
|
454 } elsif ($sortby eq "longest") {
|
|
|
455 $sortfunc .= '(($b->length) <=> ($a->length)) || ';
|
|
|
456 } elsif ($sortby eq "shortest") {
|
|
|
457 $sortfunc .= '(($a->length) <=> ($b->length)) || ';
|
|
|
458 } elsif ($sortby eq "strand") {
|
|
|
459 $sortfunc .= '($b->strand <=> $a->strand) || ';
|
|
|
460 } elsif ($sortby eq "name") {
|
|
|
461 $sortfunc .= '($a->feature->display_name cmp $b->feature->display_name) || ';
|
|
|
462 }
|
|
|
463 }
|
|
|
464 unless ($sawleft) {
|
|
|
465 $sortfunc .= ' ($a->left <=> $b->left) ';
|
|
|
466 } else {
|
|
|
467 $sortfunc .= ' 0';
|
|
|
468 }
|
|
|
469 $sortfunc .= '}';
|
|
|
470 $sortfunc = eval $sortfunc;
|
|
|
471 }
|
|
|
472
|
|
|
473 # cache this
|
|
|
474 # $self->factory->set_option(sort_order => $sortfunc);
|
|
|
475
|
|
|
476 return sort $sortfunc @_;
|
|
|
477 }
|
|
|
478
|
|
|
479 # handle collision detection
|
|
|
480 sub layout {
|
|
|
481 my $self = shift;
|
|
|
482 return $self->{layout_height} if exists $self->{layout_height};
|
|
|
483
|
|
|
484 my @parts = $self->parts;
|
|
|
485 return $self->{layout_height}
|
|
|
486 = $self->height + $self->pad_top + $self->pad_bottom unless @parts;
|
|
|
487
|
|
|
488 my $bump_direction = $self->bump;
|
|
|
489 my $bump_limit = $self->option('bump_limit') || -1;
|
|
|
490
|
|
|
491 $_->layout foreach @parts; # recursively lay out
|
|
|
492
|
|
|
493 # no bumping requested, or only one part here
|
|
|
494 if (@parts == 1 || !$bump_direction) {
|
|
|
495 my $highest = 0;
|
|
|
496 foreach (@parts) {
|
|
|
497 my $height = $_->layout_height;
|
|
|
498 $highest = $height > $highest ? $height : $highest;
|
|
|
499 }
|
|
|
500 return $self->{layout_height} = $highest + $self->pad_top + $self->pad_bottom;
|
|
|
501 }
|
|
|
502
|
|
|
503 my (%bin1,%bin2);
|
|
|
504 for my $g ($self->layout_sort(@parts)) {
|
|
|
505
|
|
|
506 my $pos = 0;
|
|
|
507 my $bumplevel = 0;
|
|
|
508 my $left = $g->left;
|
|
|
509 my $right = $g->right;
|
|
|
510 my $height = $g->{layout_height};
|
|
|
511
|
|
|
512 while (1) {
|
|
|
513
|
|
|
514 # stop bumping if we've gone too far down
|
|
|
515 if ($bump_limit > 0 && $bumplevel++ >= $bump_limit) {
|
|
|
516 $g->{overbumped}++; # this flag can be used to suppress label and description
|
|
|
517 foreach ($g->parts) {
|
|
|
518 $_->{overbumped}++;
|
|
|
519 }
|
|
|
520 last;
|
|
|
521 }
|
|
|
522
|
|
|
523 # look for collisions
|
|
|
524 my $bottom = $pos + $height;
|
|
|
525 $self->collides(\%bin1,CM1,CM2,$left,$pos,$right,$bottom) or last;
|
|
|
526 my $collision = $self->collides(\%bin2,CM3,CM4,$left,$pos,$right,$bottom) or last;
|
|
|
527
|
|
|
528 if ($bump_direction > 0) {
|
|
|
529 $pos += $collision->[3]-$collision->[1] + BUMP_SPACING; # collision, so bump
|
|
|
530
|
|
|
531 } else {
|
|
|
532 $pos -= BUMP_SPACING;
|
|
|
533 }
|
|
|
534
|
|
|
535 }
|
|
|
536
|
|
|
537 $g->move(0,$pos);
|
|
|
538 $self->add_collision(\%bin1,CM1,CM2,$left,$g->top,$right,$g->bottom);
|
|
|
539 $self->add_collision(\%bin2,CM3,CM4,$left,$g->top,$right,$g->bottom);
|
|
|
540 }
|
|
|
541
|
|
|
542 # If -1 bumping was allowed, then normalize so that the top glyph is at zero
|
|
|
543 if ($bump_direction < 0) {
|
|
|
544 my $topmost;
|
|
|
545 foreach (@parts) {
|
|
|
546 my $top = $_->top;
|
|
|
547 $topmost = $top if !defined($topmost) or $top < $topmost;
|
|
|
548 }
|
|
|
549 my $offset = - $topmost;
|
|
|
550 $_->move(0,$offset) foreach @parts;
|
|
|
551 }
|
|
|
552
|
|
|
553 # find new height
|
|
|
554 my $bottom = 0;
|
|
|
555 foreach (@parts) {
|
|
|
556 $bottom = $_->bottom if $_->bottom > $bottom;
|
|
|
557 }
|
|
|
558 return $self->{layout_height} = $self->pad_bottom + $self->pad_top + $bottom - $self->top + 1;
|
|
|
559 }
|
|
|
560
|
|
|
561 # the $%occupied structure is a hash of {left,top} = [left,top,right,bottom]
|
|
|
562 sub collides {
|
|
|
563 my $self = shift;
|
|
|
564 my ($occupied,$cm1,$cm2,$left,$top,$right,$bottom) = @_;
|
|
|
565 my @keys = $self->_collision_keys($cm1,$cm2,$left,$top,$right,$bottom);
|
|
|
566 my $collides = 0;
|
|
|
567 for my $k (@keys) {
|
|
|
568 next unless exists $occupied->{$k};
|
|
|
569 for my $bounds (@{$occupied->{$k}}) {
|
|
|
570 my ($l,$t,$r,$b) = @$bounds;
|
|
|
571 next unless $right >= $l and $left <= $r and $bottom >= $t and $top <= $b;
|
|
|
572 $collides = $bounds;
|
|
|
573 last;
|
|
|
574 }
|
|
|
575 }
|
|
|
576 $collides;
|
|
|
577 }
|
|
|
578
|
|
|
579 sub add_collision {
|
|
|
580 my $self = shift;
|
|
|
581 my ($occupied,$cm1,$cm2,$left,$top,$right,$bottom) = @_;
|
|
|
582 my $value = [$left,$top,$right+2,$bottom];
|
|
|
583 my @keys = $self->_collision_keys($cm1,$cm2,@$value);
|
|
|
584 push @{$occupied->{$_}},$value foreach @keys;
|
|
|
585 }
|
|
|
586
|
|
|
587 sub _collision_keys {
|
|
|
588 my $self = shift;
|
|
|
589 my ($binx,$biny,$left,$top,$right,$bottom) = @_;
|
|
|
590 my @keys;
|
|
|
591 my $bin_left = int($left/$binx);
|
|
|
592 my $bin_right = int($right/$binx);
|
|
|
593 my $bin_top = int($top/$biny);
|
|
|
594 my $bin_bottom = int($bottom/$biny);
|
|
|
595 for (my $x=$bin_left;$x<=$bin_right; $x++) {
|
|
|
596 for (my $y=$bin_top;$y<=$bin_bottom; $y++) {
|
|
|
597 push @keys,join(',',$x,$y);
|
|
|
598 }
|
|
|
599 }
|
|
|
600 @keys;
|
|
|
601 }
|
|
|
602
|
|
|
603 sub draw {
|
|
|
604 my $self = shift;
|
|
|
605 my $gd = shift;
|
|
|
606 my ($left,$top,$partno,$total_parts) = @_;
|
|
|
607
|
|
|
608 local($self->{partno},$self->{total_parts});
|
|
|
609 @{$self}{qw(partno total_parts)} = ($partno,$total_parts);
|
|
|
610
|
|
|
611 my $connector = $self->connector;
|
|
|
612 if (my @parts = $self->parts) {
|
|
|
613
|
|
|
614 # invoke sorter if use wants to sort always and we haven't already sorted
|
|
|
615 # during bumping.
|
|
|
616 @parts = $self->layout_sort(@parts) if !$self->bump && $self->option('always_sort');
|
|
|
617
|
|
|
618 my $x = $left;
|
|
|
619 my $y = $top + $self->top + $self->pad_top;
|
|
|
620 $self->draw_connectors($gd,$x,$y) if $connector && $connector ne 'none';
|
|
|
621
|
|
|
622 my $last_x;
|
|
|
623 for (my $i=0; $i<@parts; $i++) {
|
|
|
624 # lie just a little bit to avoid lines overlapping and
|
|
|
625 # make the picture prettier
|
|
|
626 my $fake_x = $x;
|
|
|
627 $fake_x-- if defined $last_x && $parts[$i]->left - $last_x == 1;
|
|
|
628 $parts[$i]->draw($gd,$fake_x,$y,$i,scalar(@parts));
|
|
|
629 $last_x = $parts[$i]->right;
|
|
|
630 }
|
|
|
631 }
|
|
|
632
|
|
|
633 else { # no part
|
|
|
634 $self->draw_connectors($gd,$left,$top)
|
|
|
635 if $connector && $connector ne 'none' && $self->{level} == 0;
|
|
|
636 $self->draw_component($gd,$left,$top);
|
|
|
637 }
|
|
|
638 }
|
|
|
639
|
|
|
640 # the "level" is the level of testing of the glyph
|
|
|
641 # groups are level -1, top level glyphs are level 0, subcomponents are level 1 and so forth.
|
|
|
642 sub level {
|
|
|
643 shift->{level};
|
|
|
644 }
|
|
|
645
|
|
|
646 sub draw_connectors {
|
|
|
647 my $self = shift;
|
|
|
648 return if $self->{overbumped};
|
|
|
649 my $gd = shift;
|
|
|
650 my ($dx,$dy) = @_;
|
|
|
651 my @parts = sort { $a->left <=> $b->left } $self->parts;
|
|
|
652 for (my $i = 0; $i < @parts-1; $i++) {
|
|
|
653 $self->_connector($gd,$dx,$dy,$parts[$i]->bounds,$parts[$i+1]->bounds);
|
|
|
654 }
|
|
|
655
|
|
|
656 # extra connectors going off ends
|
|
|
657 if (@parts) {
|
|
|
658 my($x1,$y1,$x2,$y2) = $self->bounds(0,0);
|
|
|
659 my($xl,$xt,$xr,$xb) = $parts[0]->bounds;
|
|
|
660 $self->_connector($gd,$dx,$dy,$x1,$xt,$x1,$xb,$xl,$xt,$xr,$xb) if $x1 < $xl;
|
|
|
661 my ($xl2,$xt2,$xr2,$xb2) = $parts[-1]->bounds;
|
|
|
662 $self->_connector($gd,$dx,$dy,$parts[-1]->bounds,$x2,$xt2,$x2,$xb2) if $x2 > $xr;
|
|
|
663 }
|
|
|
664
|
|
|
665 }
|
|
|
666
|
|
|
667 sub _connector {
|
|
|
668 my $self = shift;
|
|
|
669 my ($gd,
|
|
|
670 $dx,$dy,
|
|
|
671 $xl,$xt,$xr,$xb,
|
|
|
672 $yl,$yt,$yr,$yb) = @_;
|
|
|
673 my $left = $dx + $xr;
|
|
|
674 my $right = $dx + $yl;
|
|
|
675 my $top1 = $dy + $xt;
|
|
|
676 my $bottom1 = $dy + $xb;
|
|
|
677 my $top2 = $dy + $yt;
|
|
|
678 my $bottom2 = $dy + $yb;
|
|
|
679 # restore this comment if you don't like the group dash working
|
|
|
680 # its way backwards.
|
|
|
681 return if $right-$left < 1 && !$self->isa('Bio::Graphics::Glyph::group');
|
|
|
682
|
|
|
683 $self->draw_connector($gd,
|
|
|
684 $top1,$bottom1,$left,
|
|
|
685 $top2,$bottom2,$right,
|
|
|
686 );
|
|
|
687 }
|
|
|
688
|
|
|
689 sub draw_connector {
|
|
|
690 my $self = shift;
|
|
|
691 my $gd = shift;
|
|
|
692
|
|
|
693 my $color = $self->connector_color;
|
|
|
694 my $connector_type = $self->connector or return;
|
|
|
695
|
|
|
696 if ($connector_type eq 'hat') {
|
|
|
697 $self->draw_hat_connector($gd,$color,@_);
|
|
|
698 } elsif ($connector_type eq 'solid') {
|
|
|
699 $self->draw_solid_connector($gd,$color,@_);
|
|
|
700 } elsif ($connector_type eq 'dashed') {
|
|
|
701 $self->draw_dashed_connector($gd,$color,@_);
|
|
|
702 } elsif ($connector_type eq 'quill') {
|
|
|
703 $self->draw_quill_connector($gd,$color,@_);
|
|
|
704 } else {
|
|
|
705 ; # draw nothing
|
|
|
706 }
|
|
|
707 }
|
|
|
708
|
|
|
709 sub draw_hat_connector {
|
|
|
710 my $self = shift;
|
|
|
711 my $gd = shift;
|
|
|
712 my $color = shift;
|
|
|
713 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
|
|
|
714
|
|
|
715 my $center1 = ($top1 + $bottom1)/2;
|
|
|
716 my $quarter1 = $top1 + ($bottom1-$top1)/4;
|
|
|
717 my $center2 = ($top2 + $bottom2)/2;
|
|
|
718 my $quarter2 = $top2 + ($bottom2-$top2)/4;
|
|
|
719
|
|
|
720 if ($center1 != $center2) {
|
|
|
721 $self->draw_solid_connector($gd,$color,@_);
|
|
|
722 return;
|
|
|
723 }
|
|
|
724
|
|
|
725 if ($right - $left > 4) { # room for the inverted "V"
|
|
|
726 my $middle = $left + int(($right - $left)/2);
|
|
|
727 $gd->line($left,$center1,$middle,$top1,$color);
|
|
|
728 $gd->line($middle,$top1,$right-1,$center1,$color);
|
|
|
729 } elsif ($right-$left > 1) { # no room, just connect
|
|
|
730 $gd->line($left,$quarter1,$right-1,$quarter1,$color);
|
|
|
731 }
|
|
|
732
|
|
|
733 }
|
|
|
734
|
|
|
735 sub draw_solid_connector {
|
|
|
736 my $self = shift;
|
|
|
737 my $gd = shift;
|
|
|
738 my $color = shift;
|
|
|
739 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
|
|
|
740
|
|
|
741 my $center1 = ($top1 + $bottom1)/2;
|
|
|
742 my $center2 = ($top2 + $bottom2)/2;
|
|
|
743
|
|
|
744 $gd->line($left,$center1,$right,$center2,$color);
|
|
|
745 }
|
|
|
746
|
|
|
747 sub draw_dashed_connector {
|
|
|
748 my $self = shift;
|
|
|
749 my $gd = shift;
|
|
|
750 my $color = shift;
|
|
|
751 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
|
|
|
752
|
|
|
753 my $center1 = ($top1 + $bottom1)/2;
|
|
|
754 my $center2 = ($top2 + $bottom2)/2;
|
|
|
755
|
|
|
756 $gd->setStyle($color,$color,gdTransparent,gdTransparent,);
|
|
|
757 $gd->line($left,$center1,$right,$center2,gdStyled);
|
|
|
758 }
|
|
|
759
|
|
|
760 sub draw_quill_connector {
|
|
|
761 my $self = shift;
|
|
|
762 my $gd = shift;
|
|
|
763 my $color = shift;
|
|
|
764 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
|
|
|
765
|
|
|
766 my $center1 = ($top1 + $bottom1)/2;
|
|
|
767 my $center2 = ($top2 + $bottom2)/2;
|
|
|
768
|
|
|
769 $gd->line($left,$center1,$right,$center2,$color);
|
|
|
770 my $direction = $self->feature->strand;
|
|
|
771 return unless $direction;
|
|
|
772
|
|
|
773 if ($direction > 0) {
|
|
|
774 my $start = $left+4;
|
|
|
775 my $end = $right-1;
|
|
|
776 for (my $position=$start; $position <= $end; $position += QUILL_INTERVAL) {
|
|
|
777 $gd->line($position,$center1,$position-2,$center1-2,$color);
|
|
|
778 $gd->line($position,$center1,$position-2,$center1+2,$color);
|
|
|
779 }
|
|
|
780 } else {
|
|
|
781 my $start = $left+1;
|
|
|
782 my $end = $right-4;
|
|
|
783 for (my $position=$start; $position <= $end; $position += QUILL_INTERVAL) {
|
|
|
784 $gd->line($position,$center1,$position+2,$center1-2,$color);
|
|
|
785 $gd->line($position,$center1,$position+2,$center1+2,$color);
|
|
|
786 }
|
|
|
787 }
|
|
|
788 }
|
|
|
789
|
|
|
790 sub filled_box {
|
|
|
791 my $self = shift;
|
|
|
792 my $gd = shift;
|
|
|
793 my ($x1,$y1,$x2,$y2,$bg,$fg) = @_;
|
|
|
794
|
|
|
795 $bg ||= $self->bgcolor;
|
|
|
796 $fg ||= $self->fgcolor;
|
|
|
797 my $linewidth = $self->option('linewidth') || 1;
|
|
|
798
|
|
|
799 $gd->filledRectangle($x1,$y1,$x2,$y2,$bg);
|
|
|
800
|
|
|
801 $fg = $self->set_pen($linewidth,$fg) if $linewidth > 1;
|
|
|
802
|
|
|
803 # draw a box
|
|
|
804 $gd->rectangle($x1,$y1,$x2,$y2,$fg);
|
|
|
805
|
|
|
806 # if the left end is off the end, then cover over
|
|
|
807 # the leftmost line
|
|
|
808 my ($width) = $gd->getBounds;
|
|
|
809
|
|
|
810 $bg = $self->set_pen($linewidth,$bg) if $linewidth > 1;
|
|
|
811
|
|
|
812 $gd->line($x1,$y1+$linewidth,$x1,$y2-$linewidth,$bg)
|
|
|
813 if $x1 < $self->panel->pad_left;
|
|
|
814
|
|
|
815 $gd->line($x2,$y1+$linewidth,$x2,$y2-$linewidth,$bg)
|
|
|
816 if $x2 > $width - $self->panel->pad_right;
|
|
|
817 }
|
|
|
818
|
|
|
819 sub filled_oval {
|
|
|
820 my $self = shift;
|
|
|
821 my $gd = shift;
|
|
|
822 my ($x1,$y1,$x2,$y2,$bg,$fg) = @_;
|
|
|
823 my $cx = ($x1+$x2)/2;
|
|
|
824 my $cy = ($y1+$y2)/2;
|
|
|
825
|
|
|
826 $fg ||= $self->fgcolor;
|
|
|
827 $bg ||= $self->bgcolor;
|
|
|
828 my $linewidth = $self->linewidth;
|
|
|
829
|
|
|
830 $fg = $self->set_pen($linewidth) if $linewidth > 1;
|
|
|
831 $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg);
|
|
|
832
|
|
|
833 # and fill it
|
|
|
834 $gd->fill($cx,$cy,$bg);
|
|
|
835 }
|
|
|
836
|
|
|
837 sub oval {
|
|
|
838 my $self = shift;
|
|
|
839 my $gd = shift;
|
|
|
840 my ($x1,$y1,$x2,$y2) = @_;
|
|
|
841 my $cx = ($x1+$x2)/2;
|
|
|
842 my $cy = ($y1+$y2)/2;
|
|
|
843
|
|
|
844 my $fg = $self->fgcolor;
|
|
|
845 my $linewidth = $self->linewidth;
|
|
|
846
|
|
|
847 $fg = $self->set_pen($linewidth) if $linewidth > 1;
|
|
|
848 $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg);
|
|
|
849 }
|
|
|
850
|
|
|
851 sub filled_arrow {
|
|
|
852 my $self = shift;
|
|
|
853 my $gd = shift;
|
|
|
854 my $orientation = shift;
|
|
|
855 $orientation *= -1 if $self->{flip};
|
|
|
856
|
|
|
857 my ($x1,$y1,$x2,$y2) = @_;
|
|
|
858
|
|
|
859 my ($width) = $gd->getBounds;
|
|
|
860 my $indent = $y2-$y1 < $x2-$x1 ? $y2-$y1 : ($x2-$x1)/2;
|
|
|
861
|
|
|
862 return $self->filled_box($gd,@_)
|
|
|
863 if ($orientation == 0)
|
|
|
864 or ($x1 < 0 && $orientation < 0)
|
|
|
865 or ($x2 > $width && $orientation > 0)
|
|
|
866 or ($indent <= 0)
|
|
|
867 or ($x2 - $x1 < 3);
|
|
|
868
|
|
|
869 my $fg = $self->fgcolor;
|
|
|
870 if ($orientation >= 0) {
|
|
|
871 $gd->line($x1,$y1,$x2-$indent,$y1,$fg);
|
|
|
872 $gd->line($x2-$indent,$y1,$x2,($y2+$y1)/2,$fg);
|
|
|
873 $gd->line($x2,($y2+$y1)/2,$x2-$indent,$y2,$fg);
|
|
|
874 $gd->line($x2-$indent,$y2,$x1,$y2,$fg);
|
|
|
875 $gd->line($x1,$y2,$x1,$y1,$fg);
|
|
|
876 my $left = $self->panel->left > $x1 ? $self->panel->left : $x1;
|
|
|
877 $gd->fillToBorder($left+1,($y1+$y2)/2,$fg,$self->bgcolor);
|
|
|
878 } else {
|
|
|
879 $gd->line($x1,($y2+$y1)/2,$x1+$indent,$y1,$fg);
|
|
|
880 $gd->line($x1+$indent,$y1,$x2,$y1,$fg);
|
|
|
881 $gd->line($x2,$y2,$x1+$indent,$y2,$fg);
|
|
|
882 $gd->line($x1+$indent,$y2,$x1,($y1+$y2)/2,$fg);
|
|
|
883 $gd->line($x2,$y1,$x2,$y2,$fg);
|
|
|
884 my $right = $self->panel->right < $x2 ? $self->panel->right : $x2;
|
|
|
885 $gd->fillToBorder($right-1,($y1+$y2)/2,$fg,$self->bgcolor);
|
|
|
886 }
|
|
|
887 }
|
|
|
888
|
|
|
889 sub linewidth {
|
|
|
890 shift->option('linewidth') || 1;
|
|
|
891 }
|
|
|
892
|
|
|
893 sub fill {
|
|
|
894 my $self = shift;
|
|
|
895 my $gd = shift;
|
|
|
896 my ($x1,$y1,$x2,$y2) = @_;
|
|
|
897 if ( ($x2-$x1) >= 2 && ($y2-$y1) >= 2 ) {
|
|
|
898 $gd->fill($x1+1,$y1+1,$self->bgcolor);
|
|
|
899 }
|
|
|
900 }
|
|
|
901 sub set_pen {
|
|
|
902 my $self = shift;
|
|
|
903 my ($linewidth,$color) = @_;
|
|
|
904 $linewidth ||= $self->linewidth;
|
|
|
905 $color ||= $self->fgcolor;
|
|
|
906 return $color unless $linewidth > 1;
|
|
|
907 $self->panel->set_pen($linewidth,$color);
|
|
|
908 }
|
|
|
909
|
|
|
910 sub draw_component {
|
|
|
911 my $self = shift;
|
|
|
912 my $gd = shift;
|
|
|
913 my($x1,$y1,$x2,$y2) = $self->bounds(@_);
|
|
|
914
|
|
|
915 # clipping
|
|
|
916 my $panel = $self->panel;
|
|
|
917 return unless $x2 >= $panel->left and $x1 <= $panel->right;
|
|
|
918
|
|
|
919 if ($self->option('strand_arrow') || $self->option('stranded')) {
|
|
|
920 $self->filled_arrow($gd,$self->feature->strand,
|
|
|
921 $x1, $y1,
|
|
|
922 $x2, $y2)
|
|
|
923 } else {
|
|
|
924 $self->filled_box($gd,
|
|
|
925 $x1, $y1,
|
|
|
926 $x2, $y2)
|
|
|
927 }
|
|
|
928 }
|
|
|
929
|
|
|
930 # memoize _subseq -- it's a bottleneck with segments
|
|
|
931 sub subseq {
|
|
|
932 my $self = shift;
|
|
|
933 my $feature = shift;
|
|
|
934 return $self->_subseq($feature) unless ref $self;
|
|
|
935 return @{$self->{cached_subseq}{$feature}} if $self->{cached_subseq}{$feature};
|
|
|
936 my @ss = $self->_subseq($feature);
|
|
|
937 $self->{cached_subseq}{$feature} = \@ss;
|
|
|
938 @ss;
|
|
|
939 }
|
|
|
940
|
|
|
941 sub _subseq {
|
|
|
942 my $class = shift;
|
|
|
943 my $feature = shift;
|
|
|
944 return $feature->merged_segments if $feature->can('merged_segments');
|
|
|
945 return $feature->segments if $feature->can('segments');
|
|
|
946 my @split = eval { my $id = $feature->location->seq_id;
|
|
|
947 my @subs = $feature->location->sub_Location;
|
|
|
948 grep {$id eq $_->seq_id} @subs};
|
|
|
949 return @split if @split;
|
|
|
950 return $feature->sub_SeqFeature if $feature->can('sub_SeqFeature');
|
|
|
951 return;
|
|
|
952 }
|
|
|
953
|
|
|
954 # synthesize a key glyph
|
|
|
955 sub keyglyph {
|
|
|
956 my $self = shift;
|
|
|
957 my $feature = $self->make_key_feature;
|
|
|
958 my $factory = $self->factory->clone;
|
|
|
959 $factory->set_option(label => 1);
|
|
|
960 $factory->set_option(description => 0);
|
|
|
961 $factory->set_option(bump => 0);
|
|
|
962 $factory->set_option(connector => 'solid');
|
|
|
963 return $factory->make_glyph(0,$feature);
|
|
|
964 }
|
|
|
965
|
|
|
966 # synthesize a key glyph
|
|
|
967 sub make_key_feature {
|
|
|
968 my $self = shift;
|
|
|
969
|
|
|
970 my $scale = 1/$self->scale; # base pairs/pixel
|
|
|
971
|
|
|
972 # one segments, at pixels 0->80
|
|
|
973 my $offset = $self->panel->offset;
|
|
|
974
|
|
|
975
|
|
|
976 my $feature =
|
|
|
977 Bio::Graphics::Feature->new(-start =>0 * $scale +$offset,
|
|
|
978 -end =>80*$scale+$offset,
|
|
|
979 -name => $self->option('key'),
|
|
|
980 -strand => '+1');
|
|
|
981 return $feature;
|
|
|
982 }
|
|
|
983
|
|
|
984 sub all_callbacks {
|
|
|
985 my $self = shift;
|
|
|
986 my $track_level = $self->option('all_callbacks');
|
|
|
987 return $track_level if defined $track_level;
|
|
|
988 return $self->panel->all_callbacks;
|
|
|
989 }
|
|
|
990
|
|
|
991 sub default_factory {
|
|
|
992 croak "no default factory implemented";
|
|
|
993 }
|
|
|
994
|
|
|
995 1;
|
|
|
996
|
|
|
997 __END__
|
|
|
998
|
|
|
999 =head1 NAME
|
|
|
1000
|
|
|
1001 Bio::Graphics::Glyph - Base class for Bio::Graphics::Glyph objects
|
|
|
1002
|
|
|
1003 =head1 SYNOPSIS
|
|
|
1004
|
|
|
1005 See L<Bio::Graphics::Panel>.
|
|
|
1006
|
|
|
1007 =head1 DESCRIPTION
|
|
|
1008
|
|
|
1009 Bio::Graphics::Glyph is the base class for all glyph objects. Each
|
|
|
1010 glyph is a wrapper around an Bio:SeqFeatureI object, knows how to
|
|
|
1011 render itself on an Bio::Graphics::Panel, and has a variety of
|
|
|
1012 configuration variables.
|
|
|
1013
|
|
|
1014 End developers will not ordinarily work directly with
|
|
|
1015 Bio::Graphics::Glyph objects, but with Bio::Graphics::Glyph::generic
|
|
|
1016 and its subclasses. Similarly, most glyph developers will want to
|
|
|
1017 subclass from Bio::Graphics::Glyph::generic because the latter
|
|
|
1018 provides labeling and arrow-drawing facilities.
|
|
|
1019
|
|
|
1020 =head1 METHODS
|
|
|
1021
|
|
|
1022 This section describes the class and object methods for
|
|
|
1023 Bio::Graphics::Glyph.
|
|
|
1024
|
|
|
1025 =head2 CONSTRUCTORS
|
|
|
1026
|
|
|
1027 Bio::Graphics::Glyph objects are constructed automatically by an
|
|
|
1028 Bio::Graphics::Glyph::Factory, and are not usually created by
|
|
|
1029 end-developer code.
|
|
|
1030
|
|
|
1031 =over 4
|
|
|
1032
|
|
|
1033 =item $glyph = Bio::Graphics::Glyph-E<gt>new(-feature=E<gt>$feature,-factory=E<gt>$factory)
|
|
|
1034
|
|
|
1035 Given a sequence feature, creates an Bio::Graphics::Glyph object to
|
|
|
1036 display it. The B<-feature> argument points to the Bio:SeqFeatureI
|
|
|
1037 object to display, and B<-factory> indicates an
|
|
|
1038 Bio::Graphics::Glyph::Factory object from which the glyph will fetch
|
|
|
1039 all its run-time configuration information. Factories are created and
|
|
|
1040 manipulated by the Bio::Graphics::Panel object.
|
|
|
1041
|
|
|
1042 A standard set of options are recognized. See L<OPTIONS>.
|
|
|
1043
|
|
|
1044 =back
|
|
|
1045
|
|
|
1046 =head2 OBJECT METHODS
|
|
|
1047
|
|
|
1048 Once a glyph is created, it responds to a large number of methods. In
|
|
|
1049 this section, these methods are grouped into related categories.
|
|
|
1050
|
|
|
1051 Retrieving glyph context:
|
|
|
1052
|
|
|
1053 =over 4
|
|
|
1054
|
|
|
1055 =item $factory = $glyph-E<gt>factory
|
|
|
1056
|
|
|
1057 Get the Bio::Graphics::Glyph::Factory associated with this object.
|
|
|
1058 This cannot be changed once it is set.
|
|
|
1059
|
|
|
1060 =item $panel = $glyph-E<gt>panel
|
|
|
1061
|
|
|
1062 Get the Bio::Graphics::Panel associated with this object. This cannot
|
|
|
1063 be changed once it is set.
|
|
|
1064
|
|
|
1065 =item $feature = $glyph-E<gt>feature
|
|
|
1066
|
|
|
1067 Get the sequence feature associated with this object. This cannot be
|
|
|
1068 changed once it is set.
|
|
|
1069
|
|
|
1070 =item $feature = $glyph-E<gt>add_feature(@features)
|
|
|
1071
|
|
|
1072 Add the list of features to the glyph, creating subparts. This is
|
|
|
1073 most common done with the track glyph returned by
|
|
|
1074 Ace::Graphics::Panel-E<gt>add_track().
|
|
|
1075
|
|
|
1076 =item $feature = $glyph-E<gt>add_group(@features)
|
|
|
1077
|
|
|
1078 This is similar to add_feature(), but the list of features is treated
|
|
|
1079 as a group and can be configured as a set.
|
|
|
1080
|
|
|
1081 =back
|
|
|
1082
|
|
|
1083 Retrieving glyph options:
|
|
|
1084
|
|
|
1085 =over 4
|
|
|
1086
|
|
|
1087 =item $fgcolor = $glyph-E<gt>fgcolor
|
|
|
1088
|
|
|
1089 =item $bgcolor = $glyph-E<gt>bgcolor
|
|
|
1090
|
|
|
1091 =item $fontcolor = $glyph-E<gt>fontcolor
|
|
|
1092
|
|
|
1093 =item $fontcolor = $glyph-E<gt>font2color
|
|
|
1094
|
|
|
1095 =item $fillcolor = $glyph-E<gt>fillcolor
|
|
|
1096
|
|
|
1097 These methods return the configured foreground, background, font,
|
|
|
1098 alternative font, and fill colors for the glyph in the form of a
|
|
|
1099 GD::Image color index.
|
|
|
1100
|
|
|
1101 =item $color = $glyph-E<gt>tkcolor
|
|
|
1102
|
|
|
1103 This method returns a color to be used to flood-fill the entire glyph
|
|
|
1104 before drawing (currently used by the "track" glyph).
|
|
|
1105
|
|
|
1106 =item $width = $glyph-E<gt>width([$newwidth])
|
|
|
1107
|
|
|
1108 Return the width of the glyph, not including left or right padding.
|
|
|
1109 This is ordinarily set internally based on the size of the feature and
|
|
|
1110 the scale of the panel.
|
|
|
1111
|
|
|
1112 =item $width = $glyph-E<gt>layout_width
|
|
|
1113
|
|
|
1114 Returns the width of the glyph including left and right padding.
|
|
|
1115
|
|
|
1116 =item $width = $glyph-E<gt>height
|
|
|
1117
|
|
|
1118 Returns the height of the glyph, not including the top or bottom
|
|
|
1119 padding. This is calculated from the "height" option and cannot be
|
|
|
1120 changed.
|
|
|
1121
|
|
|
1122
|
|
|
1123 =item $font = $glyph-E<gt>font
|
|
|
1124
|
|
|
1125 Return the font for the glyph.
|
|
|
1126
|
|
|
1127 =item $option = $glyph-E<gt>option($option)
|
|
|
1128
|
|
|
1129 Return the value of the indicated option.
|
|
|
1130
|
|
|
1131 =item $index = $glyph-E<gt>color($color)
|
|
|
1132
|
|
|
1133 Given a symbolic or #RRGGBB-form color name, returns its GD index.
|
|
|
1134
|
|
|
1135 =item $level = $glyph-E<gt>level
|
|
|
1136
|
|
|
1137 The "level" is the nesting level of the glyph.
|
|
|
1138 Groups are level -1, top level glyphs are level 0,
|
|
|
1139 subparts (e.g. exons) are level 1 and so forth.
|
|
|
1140
|
|
|
1141 =back
|
|
|
1142
|
|
|
1143 Setting an option:
|
|
|
1144
|
|
|
1145 =over 4
|
|
|
1146
|
|
|
1147 =item $glyph-E<gt>configure(-name=E<gt>$value)
|
|
|
1148
|
|
|
1149 You may change a glyph option after it is created using set_option().
|
|
|
1150 This is most commonly used to configure track glyphs.
|
|
|
1151
|
|
|
1152 =back
|
|
|
1153
|
|
|
1154 Retrieving information about the sequence:
|
|
|
1155
|
|
|
1156 =over 4
|
|
|
1157
|
|
|
1158 =item $start = $glyph-E<gt>start
|
|
|
1159
|
|
|
1160 =item $end = $glyph-E<gt>end
|
|
|
1161
|
|
|
1162 These methods return the start and end of the glyph in base pair
|
|
|
1163 units.
|
|
|
1164
|
|
|
1165 =item $offset = $glyph-E<gt>offset
|
|
|
1166
|
|
|
1167 Returns the offset of the segment (the base pair at the far left of
|
|
|
1168 the image).
|
|
|
1169
|
|
|
1170 =item $length = $glyph-E<gt>length
|
|
|
1171
|
|
|
1172 Returns the length of the sequence segment.
|
|
|
1173
|
|
|
1174 =back
|
|
|
1175
|
|
|
1176
|
|
|
1177 Retrieving formatting information:
|
|
|
1178
|
|
|
1179 =over 4
|
|
|
1180
|
|
|
1181 =item $top = $glyph-E<gt>top
|
|
|
1182
|
|
|
1183 =item $left = $glyph-E<gt>left
|
|
|
1184
|
|
|
1185 =item $bottom = $glyph-E<gt>bottom
|
|
|
1186
|
|
|
1187 =item $right = $glyph-E<gt>right
|
|
|
1188
|
|
|
1189 These methods return the top, left, bottom and right of the glyph in
|
|
|
1190 pixel coordinates.
|
|
|
1191
|
|
|
1192 =item $height = $glyph-E<gt>height
|
|
|
1193
|
|
|
1194 Returns the height of the glyph. This may be somewhat larger or
|
|
|
1195 smaller than the height suggested by the GlyphFactory, depending on
|
|
|
1196 the type of the glyph.
|
|
|
1197
|
|
|
1198 =item $scale = $glyph-E<gt>scale
|
|
|
1199
|
|
|
1200 Get the scale for the glyph in pixels/bp.
|
|
|
1201
|
|
|
1202 =item $height = $glyph-E<gt>labelheight
|
|
|
1203
|
|
|
1204 Return the height of the label, if any.
|
|
|
1205
|
|
|
1206 =item $label = $glyph-E<gt>label
|
|
|
1207
|
|
|
1208 Return a human-readable label for the glyph.
|
|
|
1209
|
|
|
1210 =back
|
|
|
1211
|
|
|
1212 These methods are called by Bio::Graphics::Track during the layout
|
|
|
1213 process:
|
|
|
1214
|
|
|
1215 =over 4
|
|
|
1216
|
|
|
1217 =item $glyph-E<gt>move($dx,$dy)
|
|
|
1218
|
|
|
1219 Move the glyph in pixel coordinates by the indicated delta-x and
|
|
|
1220 delta-y values.
|
|
|
1221
|
|
|
1222 =item ($x1,$y1,$x2,$y2) = $glyph-E<gt>box
|
|
|
1223
|
|
|
1224 Return the current position of the glyph.
|
|
|
1225
|
|
|
1226 =back
|
|
|
1227
|
|
|
1228 These methods are intended to be overridden in subclasses:
|
|
|
1229
|
|
|
1230 =over 4
|
|
|
1231
|
|
|
1232 =item $glyph-E<gt>calculate_height
|
|
|
1233
|
|
|
1234 Calculate the height of the glyph.
|
|
|
1235
|
|
|
1236 =item $glyph-E<gt>calculate_left
|
|
|
1237
|
|
|
1238 Calculate the left side of the glyph.
|
|
|
1239
|
|
|
1240 =item $glyph-E<gt>calculate_right
|
|
|
1241
|
|
|
1242 Calculate the right side of the glyph.
|
|
|
1243
|
|
|
1244 =item $glyph-E<gt>draw($gd,$left,$top)
|
|
|
1245
|
|
|
1246 Optionally offset the glyph by the indicated amount and draw it onto
|
|
|
1247 the GD::Image object.
|
|
|
1248
|
|
|
1249
|
|
|
1250 =item $glyph-E<gt>draw_label($gd,$left,$top)
|
|
|
1251
|
|
|
1252 Draw the label for the glyph onto the provided GD::Image object,
|
|
|
1253 optionally offsetting by the amounts indicated in $left and $right.
|
|
|
1254
|
|
|
1255 =back
|
|
|
1256
|
|
|
1257 These methods are useful utility routines:
|
|
|
1258
|
|
|
1259 =over 4
|
|
|
1260
|
|
|
1261 =item $pixels = $glyph-E<gt>map_pt($bases);
|
|
|
1262
|
|
|
1263 Map the indicated base position, given in base pair units, into
|
|
|
1264 pixels, using the current scale and glyph position.
|
|
|
1265
|
|
|
1266 =item $glyph-E<gt>filled_box($gd,$x1,$y1,$x2,$y2)
|
|
|
1267
|
|
|
1268 Draw a filled rectangle with the appropriate foreground and fill
|
|
|
1269 colors, and pen width onto the GD::Image object given by $gd, using
|
|
|
1270 the provided rectangle coordinates.
|
|
|
1271
|
|
|
1272 =item $glyph-E<gt>filled_oval($gd,$x1,$y1,$x2,$y2)
|
|
|
1273
|
|
|
1274 As above, but draws an oval inscribed on the rectangle.
|
|
|
1275
|
|
|
1276 =back
|
|
|
1277
|
|
|
1278 =head2 OPTIONS
|
|
|
1279
|
|
|
1280 The following options are standard among all Glyphs. See individual
|
|
|
1281 glyph pages for more options.
|
|
|
1282
|
|
|
1283 Option Description Default
|
|
|
1284 ------ ----------- -------
|
|
|
1285
|
|
|
1286 -fgcolor Foreground color black
|
|
|
1287
|
|
|
1288 -outlinecolor Synonym for -fgcolor
|
|
|
1289
|
|
|
1290 -bgcolor Background color turquoise
|
|
|
1291
|
|
|
1292 -fillcolor Synonym for -bgcolor
|
|
|
1293
|
|
|
1294 -linewidth Line width 1
|
|
|
1295
|
|
|
1296 -height Height of glyph 10
|
|
|
1297
|
|
|
1298 -font Glyph font gdSmallFont
|
|
|
1299
|
|
|
1300 -connector Connector type undef (false)
|
|
|
1301
|
|
|
1302 -connector_color
|
|
|
1303 Connector color black
|
|
|
1304
|
|
|
1305 -strand_arrow Whether to indicate undef (false)
|
|
|
1306 strandedness
|
|
|
1307
|
|
|
1308 -label Whether to draw a label undef (false)
|
|
|
1309
|
|
|
1310 -description Whether to draw a description undef (false)
|
|
|
1311
|
|
|
1312 -sort_order Specify layout sort order "default"
|
|
|
1313
|
|
|
1314 -always_sort Sort even when bumping is off undef (false)
|
|
|
1315
|
|
|
1316 -bump_limit Maximum number of levels to bump undef (unlimited)
|
|
|
1317
|
|
|
1318 For glyphs that consist of multiple segments, the B<-connector> option
|
|
|
1319 controls what's drawn between the segments. The default is undef (no
|
|
|
1320 connector). Options include:
|
|
|
1321
|
|
|
1322 "hat" an upward-angling conector
|
|
|
1323 "solid" a straight horizontal connector
|
|
|
1324 "quill" a decorated line with small arrows indicating strandedness
|
|
|
1325 (like the UCSC Genome Browser uses)
|
|
|
1326 "dashed" a horizontal dashed line.
|
|
|
1327
|
|
|
1328 The B<-connector_color> option controls the color of the connector, if
|
|
|
1329 any.
|
|
|
1330
|
|
|
1331 The label is printed above the glyph. You may pass an anonymous
|
|
|
1332 subroutine to B<-label>, in which case the subroutine will be invoked
|
|
|
1333 with the feature as its single argument. and is expected to return
|
|
|
1334 the string to use as the description. If you provide the numeric
|
|
|
1335 value "1" to B<-description>, the description will be read off the
|
|
|
1336 feature's seqname(), info() and primary_tag() methods will be called
|
|
|
1337 until a suitable name is found. To create a label with the
|
|
|
1338 text "1", pass the string "1 ". (A 1 followed by a space).
|
|
|
1339
|
|
|
1340 The description is printed below the glyph. You may pass an anonymous
|
|
|
1341 subroutine to B<-description>, in which case the subroutine will be
|
|
|
1342 invoked with the feature as its single argument and is expected to
|
|
|
1343 return the string to use as the description. If you provide the
|
|
|
1344 numeric value "1" to B<-description>, the description will be read off
|
|
|
1345 the feature's source_tag() method. To create a description with the
|
|
|
1346 text "1", pass the string "1 ". (A 1 followed by a space).
|
|
|
1347
|
|
|
1348 In the case of ACEDB Ace::Sequence feature objects, the feature's
|
|
|
1349 info(), Brief_identification() and Locus() methods will be called to
|
|
|
1350 create a suitable description.
|
|
|
1351
|
|
|
1352 The B<-strand_arrow> option, if true, requests that the glyph indicate
|
|
|
1353 which strand it is on, usually by drawing an arrowhead. Not all
|
|
|
1354 glyphs will respond to this request. For historical reasons,
|
|
|
1355 B<-stranded> is a synonym for this option.
|
|
|
1356
|
|
|
1357 By default, features are drawn with a layout based only on the
|
|
|
1358 position of the feature, assuring a maximal "packing" of the glyphs
|
|
|
1359 when bumped. In some cases, however, it makes sense to display the
|
|
|
1360 glyphs sorted by score or some other comparison, e.g. such that more
|
|
|
1361 "important" features are nearer the top of the display, stacked above
|
|
|
1362 less important features. The -sort_order option allows a few
|
|
|
1363 different built-in values for changing the default sort order (which
|
|
|
1364 is by "left" position): "low_score" (or "high_score") will cause
|
|
|
1365 features to be sorted from lowest to highest score (or vice versa).
|
|
|
1366 "left" (or "default") and "right" values will cause features to be
|
|
|
1367 sorted by their position in the sequence. "longer" (or "shorter")
|
|
|
1368 will cause the longest (or shortest) features to be sorted first, and
|
|
|
1369 "strand" will cause the features to be sorted by strand: "+1"
|
|
|
1370 (forward) then "0" (unknown, or NA) then "-1" (reverse). Lastly,
|
|
|
1371 "name" will sort features alphabetically by their display_name()
|
|
|
1372 attribute.
|
|
|
1373
|
|
|
1374 In all cases, the "left" position will be used to break any ties. To
|
|
|
1375 break ties using another field, options may be strung together using a
|
|
|
1376 "|" character; e.g. "strand|low_score|right" would cause the features
|
|
|
1377 to be sorted first by strand, then score (lowest to highest), then by
|
|
|
1378 "right" position in the sequence. Finally, a subroutine coderef can
|
|
|
1379 be provided, which should expect to receive two feature objects (via
|
|
|
1380 the special sort variables $a and $b), and should return -1, 0 or 1
|
|
|
1381 (see Perl's sort() function for more information); this subroutine
|
|
|
1382 will be used without further modification for sorting. For example,
|
|
|
1383 to sort a set of database search hits by bits (stored in the features'
|
|
|
1384 "score" fields), scaled by the log of the alignment length (with
|
|
|
1385 "left" position breaking any ties):
|
|
|
1386
|
|
|
1387 sort_order = sub { ( $b->score/log($b->length)
|
|
|
1388 <=>
|
|
|
1389 $a->score/log($a->length) )
|
|
|
1390 ||
|
|
|
1391 ( $a->start <=> $b->start )
|
|
|
1392 }
|
|
|
1393
|
|
|
1394 The -always_sort option, if true, will sort features even if bumping
|
|
|
1395 is turned off. This is useful if you would like overlapping features
|
|
|
1396 to stack in a particular order. Features towards the end of the list
|
|
|
1397 will overlay those towards the beginning of the sort order.
|
|
|
1398
|
|
|
1399 =head1 SUBCLASSING Bio::Graphics::Glyph
|
|
|
1400
|
|
|
1401 By convention, subclasses are all lower-case. Begin each subclass
|
|
|
1402 with a preamble like this one:
|
|
|
1403
|
|
|
1404 package Bio::Graphics::Glyph::crossbox;
|
|
|
1405
|
|
|
1406 use strict;
|
|
|
1407 use vars '@ISA';
|
|
|
1408 @ISA = 'Bio::Graphics::Glyph';
|
|
|
1409
|
|
|
1410 Then override the methods you need to. Typically, just the draw()
|
|
|
1411 method will need to be overridden. However, if you need additional
|
|
|
1412 room in the glyph, you may override calculate_height(),
|
|
|
1413 calculate_left() and calculate_right(). Do not directly override
|
|
|
1414 height(), left() and right(), as their purpose is to cache the values
|
|
|
1415 returned by their calculating cousins in order to avoid time-consuming
|
|
|
1416 recalculation.
|
|
|
1417
|
|
|
1418 A simple draw() method looks like this:
|
|
|
1419
|
|
|
1420 sub draw {
|
|
|
1421 my $self = shift;
|
|
|
1422 $self->SUPER::draw(@_);
|
|
|
1423 my $gd = shift;
|
|
|
1424
|
|
|
1425 # and draw a cross through the box
|
|
|
1426 my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
|
|
|
1427 my $fg = $self->fgcolor;
|
|
|
1428 $gd->line($x1,$y1,$x2,$y2,$fg);
|
|
|
1429 $gd->line($x1,$y2,$x2,$y1,$fg);
|
|
|
1430 }
|
|
|
1431
|
|
|
1432 This subclass draws a simple box with two lines criss-crossed through
|
|
|
1433 it. We first call our inherited draw() method to generate the filled
|
|
|
1434 box and label. We then call calculate_boundaries() to return the
|
|
|
1435 coordinates of the glyph, disregarding any extra space taken by
|
|
|
1436 labels. We call fgcolor() to return the desired foreground color, and
|
|
|
1437 then call $gd-E<gt>line() twice to generate the criss-cross.
|
|
|
1438
|
|
|
1439 For more complex draw() methods, see Bio::Graphics::Glyph::transcript
|
|
|
1440 and Bio::Graphics::Glyph::segments.
|
|
|
1441
|
|
|
1442 =head1 BUGS
|
|
|
1443
|
|
|
1444 Please report them.
|
|
|
1445
|
|
|
1446 =head1 SEE ALSO
|
|
|
1447
|
|
|
1448 L<Bio::DB::GFF::Feature>,
|
|
|
1449 L<Ace::Sequence>,
|
|
|
1450 L<Bio::Graphics::Panel>,
|
|
|
1451 L<Bio::Graphics::Track>,
|
|
|
1452 L<Bio::Graphics::Glyph::anchored_arrow>,
|
|
|
1453 L<Bio::Graphics::Glyph::arrow>,
|
|
|
1454 L<Bio::Graphics::Glyph::box>,
|
|
|
1455 L<Bio::Graphics::Glyph::dna>,
|
|
|
1456 L<Bio::Graphics::Glyph::graded_segments>,
|
|
|
1457 L<Bio::Graphics::Glyph::primers>,
|
|
|
1458 L<Bio::Graphics::Glyph::segments>,
|
|
|
1459 L<Bio::Graphics::Glyph::toomany>,
|
|
|
1460 L<Bio::Graphics::Glyph::transcript>,
|
|
|
1461 L<Bio::Graphics::Glyph::transcript2>,
|
|
|
1462 L<Bio::Graphics::Glyph::wormbase_transcript>
|
|
|
1463
|
|
|
1464 =head1 AUTHOR
|
|
|
1465
|
|
|
1466 Lincoln Stein E<lt>lstein@cshl.orgE<gt>
|
|
|
1467
|
|
|
1468 Copyright (c) 2001 Cold Spring Harbor Laboratory
|
|
|
1469
|
|
|
1470 This library is free software; you can redistribute it and/or modify
|
|
|
1471 it under the same terms as Perl itself. See DISCLAIMER.txt for
|
|
|
1472 disclaimers of warranty.
|
|
|
1473
|
|
|
1474 =cut
|
