|
0
|
1 package Bio::Graphics::Glyph::arrow;
|
|
|
2 # package to use for drawing an arrow
|
|
|
3
|
|
|
4 use strict;
|
|
|
5 use vars '@ISA';
|
|
|
6 use Bio::Graphics::Glyph::generic;
|
|
|
7 @ISA = 'Bio::Graphics::Glyph::generic';
|
|
|
8
|
|
|
9 my %UNITS = (n => 1e-12,
|
|
|
10 n => 1e-9,
|
|
|
11 u => 1e-6,
|
|
|
12 m => 0.001,
|
|
|
13 c => 0.01,
|
|
|
14 k => 1000,
|
|
|
15 M => 1_000_000,
|
|
|
16 G => 1_000_000_000);
|
|
|
17
|
|
|
18 sub pad_bottom {
|
|
|
19 my $self = shift;
|
|
|
20 my $val = $self->SUPER::pad_bottom(@_);
|
|
|
21 $val += $self->font->height if $self->option('tick');
|
|
|
22 $val;
|
|
|
23 }
|
|
|
24
|
|
|
25 # override draw method
|
|
|
26 sub draw {
|
|
|
27 my $self = shift;
|
|
|
28 my $parallel = $self->option('parallel');
|
|
|
29 $parallel = 1 unless defined $parallel;
|
|
|
30 $self->draw_parallel(@_) if $parallel;
|
|
|
31 $self->draw_perpendicular(@_) unless $parallel;
|
|
|
32 }
|
|
|
33
|
|
|
34 sub draw_perpendicular {
|
|
|
35 my $self = shift;
|
|
|
36 my $gd = shift;
|
|
|
37 my ($dx,$dy) = @_;
|
|
|
38 my ($x1,$y1,$x2,$y2) = $self->bounds(@_);
|
|
|
39
|
|
|
40 my $ne = $self->option('northeast');
|
|
|
41 my $sw = $self->option('southwest');
|
|
|
42 $ne = $sw = 1 unless defined($ne) || defined($sw);
|
|
|
43
|
|
|
44 # draw a perpendicular arrow at position indicated by $x1
|
|
|
45 my $fg = $self->set_pen;
|
|
|
46 my $a2 = ($y2-$y1)/4;
|
|
|
47
|
|
|
48 my @positions = $x1 == $x2 ? ($x1) : ($x1,$x2);
|
|
|
49 for my $x (@positions) {
|
|
|
50 if ($ne) {
|
|
|
51 $gd->line($x,$y1,$x,$y2,$fg);
|
|
|
52 $gd->line($x-$a2,$y1+$a2,$x,$y1,$fg);
|
|
|
53 $gd->line($x+$a2,$y1+$a2,$x,$y1,$fg);
|
|
|
54 }
|
|
|
55 if ($sw) {
|
|
|
56 $gd->line($x,$y1,$x,$y2,$fg);
|
|
|
57 $gd->line($x-$a2,$y2-$a2,$x,$y2,$fg);
|
|
|
58 $gd->line($x+$a2,$y2-$a2,$x,$y2,$fg);
|
|
|
59 }
|
|
|
60 }
|
|
|
61
|
|
|
62 # add a label if requested
|
|
|
63 $self->draw_label($gd,$dx,$dy) if $self->option('label'); # this draws the label aligned to the left
|
|
|
64 }
|
|
|
65
|
|
|
66 sub draw_parallel {
|
|
|
67 my $self = shift;
|
|
|
68 my $gd = shift;
|
|
|
69 my ($dx,$dy) = @_;
|
|
|
70 my ($x1,$y1,$x2,$y2) = $self->bounds(@_);
|
|
|
71
|
|
|
72 my $fg = $self->set_pen;
|
|
|
73 my $a2 = ($self->height)/2;
|
|
|
74 my $center = $y1+$a2;
|
|
|
75
|
|
|
76 my $trunc_left = $x1 < $self->panel->left;
|
|
|
77 my $trunc_right = $x2 > $self->panel->right;
|
|
|
78
|
|
|
79 $x1 = $self->panel->left if $trunc_left;
|
|
|
80 $x2 = $self->panel->right if $trunc_right;
|
|
|
81
|
|
|
82 $trunc_left = 0 if $self->no_trunc;
|
|
|
83 $trunc_right = 0 if $self->no_trunc;
|
|
|
84
|
|
|
85 my ($sw,$ne,$base_w,$base_e) = $self->arrowheads;
|
|
|
86 $gd->line($x1,$center,$x2,$center,$fg);
|
|
|
87 $self->arrowhead($gd,$x1,$center,$a2,-1) if $sw && !$trunc_left; # west arrow
|
|
|
88 $self->arrowhead($gd,$x2,$center,$a2,+1) if $ne && !$trunc_right; # east arrow
|
|
|
89 $gd->line($x1,$center-$a2,$x1,$center+$a2,$fg) if $base_w && !$trunc_left; #west base
|
|
|
90 $gd->line($x2,$center-$a2,$x2,$center+$a2,$fg) if $base_e && !$trunc_right; #east base
|
|
|
91
|
|
|
92 # turn on ticks
|
|
|
93 if ($self->option('tick')) {
|
|
|
94 local $^W = 0; # dumb uninitialized variable warning
|
|
|
95 my $font = $self->font;
|
|
|
96 my $width = $font->width;
|
|
|
97 my $font_color = $self->fontcolor;
|
|
|
98 my $height = $self->height;
|
|
|
99
|
|
|
100 my $relative = $self->option('relative_coords');
|
|
|
101 my $relative_coords_offset = $self->option('relative_coords_offset');
|
|
|
102 $relative_coords_offset = 1 unless ($relative_coords_offset);
|
|
|
103
|
|
|
104 my $start = $relative ? $relative_coords_offset : $self->feature->start-1;
|
|
|
105 my $stop = $start + $self->feature->length - 1;
|
|
|
106
|
|
|
107 my $offset = $relative ? ($self->feature->start - $relative_coords_offset) : 0;
|
|
|
108 my $reversed = exists $self->{flip} || ($relative && $self->feature->strand < 0);
|
|
|
109
|
|
|
110 my $unit_label = $self->option('units') || '';
|
|
|
111 my $unit_divider = $self->option('unit_divider') || 1;
|
|
|
112
|
|
|
113 my $units = $self->calculate_units($start/$unit_divider,$self->feature->length/$unit_divider);
|
|
|
114 my $divisor = $UNITS{$units} || 1;
|
|
|
115
|
|
|
116 $divisor *= $unit_divider;
|
|
|
117
|
|
|
118 my $format = min($self->feature->length,$self->panel->length)/$divisor > 10
|
|
|
119 ? "%d$units%s" : "%.6g$units%s";
|
|
|
120
|
|
|
121 my $scale = $self->option('scale') || 1; ## Does the user want to override the internal scale?
|
|
|
122
|
|
|
123 my $model = sprintf("$format ",$stop/($divisor*$scale),$unit_label);
|
|
|
124 my $minlen = $width * length($model);
|
|
|
125
|
|
|
126 my ($major_interval,$minor_interval) = $self->panel->ticks(($stop-$start+1)/$unit_divider,$minlen);
|
|
|
127
|
|
|
128 my $left = $sw ? $x1+$height : $x1;
|
|
|
129 my $right = $ne ? $x2-$height : $x2;
|
|
|
130
|
|
|
131 # adjust for portions of arrow that are outside panel
|
|
|
132 $start += $self->panel->start - $self->feature->start
|
|
|
133 if $self->feature->start < $self->panel->start;
|
|
|
134 $stop -= $self->feature->end - $self->panel->end
|
|
|
135 if $self->feature->end > $self->panel->end;
|
|
|
136
|
|
|
137 my $first_tick = $major_interval * int(0.5 + $start/$major_interval);
|
|
|
138 my $last_tick = $major_interval * int(0.5 + $stop/$major_interval);
|
|
|
139
|
|
|
140 for (my $i = $first_tick; $i <= $last_tick; $i += $major_interval) {
|
|
|
141
|
|
|
142 my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
|
|
|
143 : $self->map_pt($i + $offset));
|
|
|
144 next if $tickpos < $left or $tickpos > $right;
|
|
|
145
|
|
|
146 $gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
|
|
|
147 my $label = $scale ? $i / $scale : $i;
|
|
|
148 my $scaled = $label/$divisor;
|
|
|
149 $label = sprintf($format,$scaled,$unit_label);
|
|
|
150
|
|
|
151 my $middle = $tickpos - (length($label) * $width)/2;
|
|
|
152 next if $middle < $left or $middle > $right;
|
|
|
153
|
|
|
154 $gd->string($font,$middle,$center+$a2-1,$label,$font_color)
|
|
|
155 unless ($self->option('no_tick_label'));
|
|
|
156 }
|
|
|
157
|
|
|
158 if ($self->option('tick') >= 2) {
|
|
|
159
|
|
|
160 $first_tick = $minor_interval * int(0.5 + $start/$minor_interval);
|
|
|
161 $last_tick = $minor_interval * int(0.5 + $stop/$minor_interval);
|
|
|
162
|
|
|
163 my $a4 = $self->height/4;
|
|
|
164 for (my $i = $first_tick; $i <= $last_tick; $i += $minor_interval) {
|
|
|
165 my $tickpos = $dx + ($reversed ? $self->map_pt($stop - $i + $offset)
|
|
|
166 : $self->map_pt($i + $offset));
|
|
|
167 next if $tickpos < $left or $tickpos > $right;
|
|
|
168
|
|
|
169 $gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
|
|
|
170 }
|
|
|
171 }
|
|
|
172 }
|
|
|
173
|
|
|
174 # add a label if requested
|
|
|
175 $self->draw_label($gd,$dx,$dy) if $self->option('label');
|
|
|
176 $self->draw_description($gd,$dx,$dy) if $self->option('description');
|
|
|
177 }
|
|
|
178
|
|
|
179 sub arrowheads {
|
|
|
180 my $self = shift;
|
|
|
181 my ($ne,$sw,$base_e,$base_w);
|
|
|
182 if ($self->option('double')) {
|
|
|
183 $ne = $sw = 1;
|
|
|
184 } else {
|
|
|
185 $ne = $self->option('northeast') || $self->option('east');
|
|
|
186 $sw = $self->option('southwest') || $self->option('west');
|
|
|
187 }
|
|
|
188 # otherwise use strandedness to define the arrow
|
|
|
189 unless (defined($ne) || defined($sw)) {
|
|
|
190 # turn on both if neither specified
|
|
|
191 $ne = 1 if $self->feature->strand > 0;
|
|
|
192 $sw = 1 if $self->feature->strand < 0;
|
|
|
193 ($ne,$sw) = ($sw,$ne) if $self->{flip};
|
|
|
194 }
|
|
|
195 return ($sw,$ne,0,0) unless $self->option('base');
|
|
|
196 return ($sw,$ne,
|
|
|
197 (!$sw && $self->feature->start>= $self->panel->start),
|
|
|
198 (!$ne && $self->feature->end <= $self->panel->end));
|
|
|
199 }
|
|
|
200
|
|
|
201 sub no_trunc { 0; }
|
|
|
202
|
|
|
203 sub calculate_units {
|
|
|
204 my $self = shift;
|
|
|
205 my ($start,$length) = @_;
|
|
|
206 return 'G' if $length >= 1e9;
|
|
|
207 return 'M' if $length >= 1e6;
|
|
|
208 return 'k' if $length >= 1e3;
|
|
|
209 return '' if $length >= 1;
|
|
|
210 return 'c' if $length >= 1e-2;
|
|
|
211 return 'm' if $length >= 1e-3;
|
|
|
212 return 'u' if $length >= 1e-6;
|
|
|
213 return 'n' if $length >= 1e-9;
|
|
|
214 return 'p';
|
|
|
215 }
|
|
|
216
|
|
|
217 sub min { $_[0]<$_[1] ? $_[0] : $_[1] }
|
|
|
218
|
|
|
219 1;
|
|
|
220
|
|
|
221 __END__
|
|
|
222
|
|
|
223 =head1 NAME
|
|
|
224
|
|
|
225 Ace::Graphics::Glyph::arrow - The "arrow" glyph
|
|
|
226
|
|
|
227 =head1 SYNOPSIS
|
|
|
228
|
|
|
229 See L<Ace::Graphics::Panel> and L<Ace::Graphics::Glyph>.
|
|
|
230
|
|
|
231 =head1 DESCRIPTION
|
|
|
232
|
|
|
233 This glyph draws arrows. Depending on options, the arrows can be
|
|
|
234 labeled, be oriented vertically or horizontally, or can contain major
|
|
|
235 and minor ticks suitable for use as a scale.
|
|
|
236
|
|
|
237 =head2 OPTIONS
|
|
|
238
|
|
|
239 The following options are standard among all Glyphs. See
|
|
|
240 L<Bio::Graphics::Glyph> for a full explanation.
|
|
|
241
|
|
|
242 Option Description Default
|
|
|
243 ------ ----------- -------
|
|
|
244
|
|
|
245 -fgcolor Foreground color black
|
|
|
246
|
|
|
247 -outlinecolor Synonym for -fgcolor
|
|
|
248
|
|
|
249 -bgcolor Background color turquoise
|
|
|
250
|
|
|
251 -fillcolor Synonym for -bgcolor
|
|
|
252
|
|
|
253 -linewidth Line width 1
|
|
|
254
|
|
|
255 -height Height of glyph 10
|
|
|
256
|
|
|
257 -font Glyph font gdSmallFont
|
|
|
258
|
|
|
259 -connector Connector type 0 (false)
|
|
|
260
|
|
|
261 -connector_color
|
|
|
262 Connector color black
|
|
|
263
|
|
|
264 -label Whether to draw a label 0 (false)
|
|
|
265
|
|
|
266 -description Whether to draw a description 0 (false)
|
|
|
267
|
|
|
268 In addition to the common options, the following glyph-specific
|
|
|
269 options are recognized:
|
|
|
270
|
|
|
271 Option Description Default
|
|
|
272 ------ ----------- -------
|
|
|
273
|
|
|
274 -tick Whether to draw major 0
|
|
|
275 and minor ticks.
|
|
|
276 0 = no ticks
|
|
|
277 1 = major ticks
|
|
|
278 2 = minor ticks
|
|
|
279
|
|
|
280 -parallel Whether to draw the arrow 1 (true)
|
|
|
281 parallel to the sequence
|
|
|
282 or perpendicular to it.
|
|
|
283
|
|
|
284 -northeast Force a north or east 1 (true)
|
|
|
285 arrowhead(depending
|
|
|
286 on orientation)
|
|
|
287
|
|
|
288 -east synonym of above
|
|
|
289
|
|
|
290 -southwest Force a south or west 1 (true)
|
|
|
291 arrowhead(depending
|
|
|
292 on orientation)
|
|
|
293
|
|
|
294 -west synonym of above
|
|
|
295
|
|
|
296 -double force-doubleheaded arrow 0 (false)
|
|
|
297
|
|
|
298 -base Draw a vertical base at the 0 (false)
|
|
|
299 non-arrowhead side
|
|
|
300
|
|
|
301 -scale Reset the labels on the arrow 0 (false)
|
|
|
302 to reflect an externally
|
|
|
303 established scale.
|
|
|
304
|
|
|
305 -arrowstyle "regular" to create a simple regular
|
|
|
306 arrowhead. "filled" to create
|
|
|
307 a thick filled arrowhead
|
|
|
308
|
|
|
309 -units add units to the tick labels none
|
|
|
310 e.g. bp
|
|
|
311
|
|
|
312 -unit_divider 1
|
|
|
313 divide tick labels by the
|
|
|
314 indicated amount prior to
|
|
|
315 displaying (use, for example
|
|
|
316 if you want to display in
|
|
|
317 cR units)
|
|
|
318
|
|
|
319 Set -parallel to 0 (false) to display a point-like feature such as a
|
|
|
320 polymorphism, or to indicate an important location. If the feature
|
|
|
321 start == end, then the glyph will draw a single arrow at the
|
|
|
322 designated location:
|
|
|
323
|
|
|
324 ^
|
|
|
325 |
|
|
|
326
|
|
|
327 Otherwise, there will be two arrows at the start and end:
|
|
|
328
|
|
|
329 ^ ^
|
|
|
330 | |
|
|
|
331
|
|
|
332 Scale: Pass in a externally established scale to reset the labels on
|
|
|
333 the arrow. This is particularly useful for manually constructed
|
|
|
334 images where the founding parameters of the panel are not 1-based.
|
|
|
335 For example, a genetic map interval ranging from 0.1 - 0.3 can be
|
|
|
336 constructed by first multiplying every value by 100. Passing
|
|
|
337
|
|
|
338 arrow(-scale=>100);
|
|
|
339
|
|
|
340 will draw tick marks labelled appropriately to your external scale.
|
|
|
341
|
|
|
342 =head1 BUGS
|
|
|
343
|
|
|
344 Please report them.
|
|
|
345
|
|
|
346 =head1 SEE ALSO
|
|
|
347
|
|
|
348 L<Bio::Graphics::Panel>,
|
|
|
349 L<Bio::Graphics::Glyph>,
|
|
|
350 L<Bio::Graphics::Glyph::arrow>,
|
|
|
351 L<Bio::Graphics::Glyph::cds>,
|
|
|
352 L<Bio::Graphics::Glyph::crossbox>,
|
|
|
353 L<Bio::Graphics::Glyph::diamond>,
|
|
|
354 L<Bio::Graphics::Glyph::dna>,
|
|
|
355 L<Bio::Graphics::Glyph::dot>,
|
|
|
356 L<Bio::Graphics::Glyph::ellipse>,
|
|
|
357 L<Bio::Graphics::Glyph::extending_arrow>,
|
|
|
358 L<Bio::Graphics::Glyph::generic>,
|
|
|
359 L<Bio::Graphics::Glyph::graded_segments>,
|
|
|
360 L<Bio::Graphics::Glyph::heterogeneous_segments>,
|
|
|
361 L<Bio::Graphics::Glyph::line>,
|
|
|
362 L<Bio::Graphics::Glyph::pinsertion>,
|
|
|
363 L<Bio::Graphics::Glyph::primers>,
|
|
|
364 L<Bio::Graphics::Glyph::rndrect>,
|
|
|
365 L<Bio::Graphics::Glyph::segments>,
|
|
|
366 L<Bio::Graphics::Glyph::ruler_arrow>,
|
|
|
367 L<Bio::Graphics::Glyph::toomany>,
|
|
|
368 L<Bio::Graphics::Glyph::transcript>,
|
|
|
369 L<Bio::Graphics::Glyph::transcript2>,
|
|
|
370 L<Bio::Graphics::Glyph::translation>,
|
|
|
371 L<Bio::Graphics::Glyph::triangle>,
|
|
|
372 L<Bio::DB::GFF>,
|
|
|
373 L<Bio::SeqI>,
|
|
|
374 L<Bio::SeqFeatureI>,
|
|
|
375 L<Bio::Das>,
|
|
|
376 L<GD>
|
|
|
377
|
|
|
378 =head1 AUTHOR
|
|
|
379
|
|
|
380 Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
|
|
|
381
|
|
|
382 Copyright (c) 2001 Cold Spring Harbor Laboratory
|
|
|
383
|
|
|
384 This library is free software; you can redistribute it and/or modify
|
|
|
385 it under the same terms as Perl itself. See DISCLAIMER.txt for
|
|
|
386 disclaimers of warranty.
|
|
|
387
|
|
|
388 =cut
|
