File Coverage

lib/Bio/Graphics/Panel.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Bio::Graphics::Panel;
2              
3 1     1   1970 use strict;
  1         3  
  1         44  
4 1     1   693 use Bio::Graphics::Glyph::Factory;
  1         2  
  1         28  
5 1     1   8 use Bio::Graphics::Feature;
  1         2  
  1         19  
6 1     1   541 use Bio::Graphics::GDWrapper;
  0            
  0            
7              
8             # KEYLABELFONT must be treated as string until image_class is established
9             use constant KEYLABELFONT => 'gdMediumBoldFont';
10             use constant KEYSPACING => 5; # extra space between key columns
11             use constant KEYPADTOP => 5; # extra padding before the key starts
12             use constant KEYCOLOR => 'wheat';
13             use constant KEYSTYLE => 'bottom';
14             use constant KEYALIGN => 'left';
15             use constant GRIDCOLOR => 'lightcyan';
16             use constant GRIDMAJORCOLOR => 'lightgrey';
17             use constant MISSING_TRACK_COLOR =>'gray';
18             use constant EXTRA_RIGHT_PADDING => 30;
19              
20             use base qw(Bio::Root::Root);
21             our $GlyphScratch;
22              
23             my %COLORS; # translation table for symbolic color names to RGB triple
24             my $IMAGEMAP = 'bgmap00001';
25             read_colors();
26              
27             sub api_version { 1.8 }
28              
29             # Create a new panel of a given width and height, and add lists of features
30             # one by one
31             sub new {
32             my $class = shift;
33             $class = ref($class) || $class;
34             my %options = @_;
35              
36             $class->read_colors() unless %COLORS;
37              
38             my $length = $options{-length} || 0;
39             my $offset = $options{-offset} || 0;
40             my $spacing = $options{-spacing} || 5;
41             my $bgcolor = $options{-bgcolor} || 'white';
42             my $keyfont = $options{-key_font} || KEYLABELFONT;
43             my $keycolor = $options{-key_color} || KEYCOLOR;
44             my $keyspacing = $options{-key_spacing} || KEYSPACING;
45             my $keystyle = $options{-key_style} || KEYSTYLE;
46             my $keyalign = $options{-key_align} || KEYALIGN;
47             my $suppress_key = $options{-suppress_key} || 0;
48             my $allcallbacks = $options{-all_callbacks} || 0;
49             my $gridcolor = $options{-gridcolor} || GRIDCOLOR;
50             my $gridmajorcolor = $options{-gridmajorcolor} || GRIDMAJORCOLOR;
51             my $grid = $options{-grid} || 0;
52             my $extend_grid = $options{-extend_grid}|| 0;
53             my $flip = $options{-flip} || 0;
54             my $empty_track_style = $options{-empty_tracks} || 'key';
55             my $autopad = defined $options{-auto_pad} ? $options{-auto_pad} : 1;
56             my $truecolor = $options{-truecolor} || 0;
57             my $truetype = $options{-truetype} || 0;
58             my $image_class = ($options{-image_class} && $options{-image_class} =~ /SVG/)
59             ? 'GD::SVG'
60             : $options{-image_class} || 'GD'; # Allow users to specify GD::SVG using SVG
61             my $linkrule = $options{-link};
62             my $titlerule = $options{-title};
63             my $targetrule = $options{-target};
64             my $background = $options{-background};
65             my $postgrid = $options{-postgrid};
66             $options{-stop}||= $options{-end}; # damn damn damn
67             my $add_categories= $options{-add_category_labels};
68              
69             if (my $seg = $options{-segment}) {
70             $offset = eval {$seg->start-1} || 0;
71             $length = $seg->length;
72             }
73              
74             $offset ||= $options{-start}-1 if defined $options{-start};
75             $length ||= $options{-stop}-$options{-start}+1
76             if defined $options{-start} && defined $options{-stop};
77              
78             # bring in the image generator class, since we will need it soon anyway
79             eval "require $image_class; 1" or $class->throw($@);
80              
81             return bless {
82             tracks => [],
83             width => $options{-width} || 600,
84             pad_top => $options{-pad_top}||0,
85             pad_bottom => $options{-pad_bottom}||0,
86             pad_left => $options{-pad_left}||0,
87             pad_right => $options{-pad_right}||0,
88             global_alpha => $options{-alpha} || 0,
89             length => $length,
90             offset => $offset,
91             gridcolor => $gridcolor,
92             gridmajorcolor => $gridmajorcolor,
93             grid => $grid,
94             extend_grid => $extend_grid,
95             bgcolor => $bgcolor,
96             height => 0, # AUTO
97             spacing => $spacing,
98             key_font => $keyfont,
99             key_color => $keycolor,
100             key_spacing => $keyspacing,
101             key_style => $keystyle,
102             key_align => $keyalign,
103             suppress_key => $suppress_key,
104             background => $background,
105             postgrid => $postgrid,
106             autopad => $autopad,
107             all_callbacks => $allcallbacks,
108             truecolor => $truecolor,
109             truetype => $truetype,
110             flip => $flip,
111             linkrule => $linkrule,
112             titlerule => $titlerule,
113             targetrule => $targetrule,
114             empty_track_style => $empty_track_style,
115             image_class => $image_class,
116             image_package => $image_class . '::Image', # Accessors
117             polygon_package => $image_class . '::Polygon',
118             add_category_labels => $add_categories,
119             key_boxes => [],
120             },$class;
121             }
122              
123             sub rotate {
124             my $self = shift;
125             my $d = $self->{rotate};
126             $self->{rotate} = shift if @_;
127             $d;
128             }
129              
130             sub pad_left {
131             my $self = shift;
132             my $g = $self->{pad_left};
133             $self->{pad_left} = shift if @_;
134             $g;
135             }
136             sub pad_right {
137             my $self = shift;
138             my $g = $self->{pad_right};
139             $self->{pad_right} = shift if @_;
140             $g;
141             }
142             sub pad_top {
143             my $self = shift;
144             my $g = $self->{pad_top};
145             $self->{pad_top} = shift if @_;
146             $g;
147             }
148             sub pad_bottom {
149             my $self = shift;
150             my $g = $self->{pad_bottom};
151             $self->{pad_bottom} = shift if @_;
152             $g;
153             }
154             sub extend_grid {
155             my $self = shift;
156             my $g = $self->{extend_grid};
157             $self->{extend_grid} = shift if @_;
158             $g;
159             }
160             sub flip {
161             my $self = shift;
162             my $g = $self->{flip};
163             $self->{flip} = shift if @_;
164             $g;
165             }
166             sub truetype {
167             my $self = shift;
168             my $g = $self->{truetype};
169             $self->{truetype} = shift if @_;
170             $g;
171             }
172              
173             # values of empty_track_style are:
174             # "suppress" -- suppress empty tracks entirely (default)
175             # "key" -- show just the key in "between" mode
176             # "line" -- draw a thin grey line
177             # "dashed" -- draw a dashed line
178             sub empty_track_style {
179             my $self = shift;
180             my $g = $self->{empty_track_style};
181             $self->{empty_track_style} = shift if @_;
182             $g;
183             }
184              
185             sub key_style {
186             my $self = shift;
187             my $g = $self->{key_style};
188             $self->{key_style} = shift if @_;
189             $g;
190             }
191              
192             sub auto_pad {
193             my $self = shift;
194             my $g = $self->{autopad};
195             $self->{autopad} = shift if @_;
196             $g;
197             }
198              
199             # public routine for mapping from a base pair
200             # location to pixel coordinates
201             sub location2pixel {
202             my $self = shift;
203             my $end = $self->end + 1;
204             my @coords = $self->{flip} ? map { $end-$_ } @_ : @_;
205             $self->map_pt(@coords);
206             }
207              
208             # numerous direct calls into array used here for performance considerations
209             sub map_pt {
210             my $self = shift;
211             my $offset = $self->{offset};
212             my $scale = $self->{scale} || $self->scale;
213             my $pl = $self->{pad_left};
214             my $pr = $self->{width};
215             my $flip = $self->{flip};
216             my $length = $self->{length};
217             my @result;
218             foreach (@_) {
219             my $val = $flip
220             ? $pr - ($length - ($_- 1)) * $scale
221             : ($_-$offset-1) * $scale;
222             $val = int($val + 0.5 * ($val<=>0));
223             $val = -1 if $val < 0;
224             $val = $pr+1 if $val > $pr;
225             push @result,$val;
226             }
227             @result;
228             }
229              
230             sub map_no_trunc {
231             my $self = shift;
232             my $offset = $self->{offset};
233             my $scale = $self->scale;
234             my $pl = $self->{pad_left};
235             my $pr = $pl + $self->{width}; # - $self->{pad_right};
236             my $flip = $self->{flip};
237             my $length = $self->{length};
238             my $end = $offset+$length;
239             my @result;
240             foreach (@_) {
241             my $val = $flip ? int (0.5 + $pl + ($end - ($_- 1)) * $scale) : int (0.5 + $pl + ($_-$offset-1) * $scale);
242             push @result,$val;
243             }
244             @result;
245             }
246              
247             sub scale {
248             my $self = shift;
249             $self->{scale} ||= $self->width/($self->length);
250             }
251              
252             sub start { shift->{offset}+1}
253             sub end { $_[0]->start + $_[0]->{length}-1}
254              
255             sub offset { shift->{offset} }
256             sub width {
257             my $self = shift;
258             my $d = $self->{width};
259             $self->{width} = shift if @_;
260             $d;
261             }
262              
263             sub left {
264             my $self = shift;
265             $self->pad_left;
266             }
267             sub right {
268             my $self = shift;
269             $self->pad_left + $self->width; # - $self->pad_right;
270             }
271             sub top {
272             shift->pad_top;
273             }
274             sub bottom {
275             my $self = shift;
276             $self->height - $self->pad_bottom;
277             }
278              
279             sub spacing {
280             my $self = shift;
281             my $d = $self->{spacing};
282             $self->{spacing} = shift if @_;
283             $d;
284             }
285              
286             sub key_spacing {
287             my $self = shift;
288             my $d = $self->{key_spacing};
289             $self->{key_spacing} = shift if @_;
290             $d;
291             }
292              
293             sub length {
294             my $self = shift;
295             my $d = $self->{length};
296             if (@_) {
297             my $l = shift;
298             $l = $l->length if ref($l) && $l->can('length');
299             $self->{length} = $l;
300             }
301             $d;
302             }
303              
304             sub gridcolor {shift->{gridcolor}}
305              
306             sub gridmajorcolor {shift->{gridmajorcolor}}
307              
308             sub all_callbacks { shift->{all_callbacks} }
309              
310             sub add_track {
311             my $self = shift;
312             $self->_do_add_track(scalar(@{$self->{tracks}}),@_);
313             }
314              
315             sub unshift_track {
316             my $self = shift;
317             $self->_do_add_track(0,@_);
318             }
319              
320             sub insert_track {
321             my $self = shift;
322             my $position = shift;
323             $self->_do_add_track($position,@_);
324             }
325              
326              
327             # create a feature and factory pair
328             # see Factory.pm for the format of the options
329             # The thing returned is actually a generic Glyph
330             sub _do_add_track {
331             my $self = shift;
332             my $position = shift;
333              
334             # due to indecision, we accept features
335             # and/or glyph types in the first two arguments
336             my ($features,$glyph_name) = ([],undef);
337             while ( @_ && $_[0] !~ /^-/) {
338             my $arg = shift;
339             $features = $arg and next if ref($arg);
340             $glyph_name = $arg and next unless ref($arg);
341             }
342              
343             my %args = @_;
344             my ($map,$ss,%options);
345              
346             foreach (keys %args) {
347             (my $canonical = lc $_) =~ s/^-//;
348             if ($canonical eq 'glyph') {
349             $map = $args{$_};
350             delete $args{$_};
351             } elsif ($canonical eq 'stylesheet') {
352             $ss = $args{$_};
353             delete $args{$_};
354             } else {
355             $options{$canonical} = $args{$_};
356             }
357             }
358              
359             $glyph_name = $map if defined $map;
360             $glyph_name ||= 'generic';
361              
362             local $^W = 0; # uninitialized variable warnings under 5.00503
363              
364             my $panel_map =
365             ref($map) eq 'CODE' ? sub {
366             my $feature = shift;
367             return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'track' };
368             return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'group' };
369             return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'scale' };
370             return $map->($feature,'glyph',$self);
371             }
372             : ref($map) eq 'HASH' ? sub {
373             my $feature = shift;
374             return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'track' };
375             return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'group' };
376             return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'scale' };
377             return eval {$map->{$feature->primary_tag}} || 'generic';
378             }
379             : sub {
380             my $feature = shift;
381             return 'track' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'track' };
382             return 'group' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'group' };
383             return 'scale' if eval { defined $feature->primary_tag && $feature->primary_tag eq 'scale' };
384             return $glyph_name;
385             };
386             $self->_add_track($position,$features,-map=>$panel_map,-stylesheet=>$ss,-options=>\%options);
387             }
388              
389             sub _add_track {
390             my $self = shift;
391             my ($position,$features,@options) = @_;
392              
393             # build the list of features into a Bio::Graphics::Feature object
394             $features = [$features] unless ref $features eq 'ARRAY';
395              
396             # optional middle-level glyph is the group
397             foreach my $f (grep {ref $_ eq 'ARRAY'} @$features) {
398             next unless ref $f eq 'ARRAY';
399             $f = Bio::Graphics::Feature->new(
400             -segments=>$f,
401             -type => 'group'
402             );
403             }
404              
405             # top-level glyph is the track
406             my $feature = Bio::Graphics::Feature->new(
407             -segments=>$features,
408             -start => $self->offset+1,
409             -stop => $self->offset+$self->length,
410             -type => 'track'
411             );
412              
413             my $factory = Bio::Graphics::Glyph::Factory->new($self,@options);
414             my $track = $factory->make_glyph(-1,$feature);
415              
416             splice(@{$self->{tracks}},$position,0,$track);
417             return $track;
418             }
419              
420             sub _expand_padding {
421             my $self = shift;
422             my $track = shift;
423             my $extra_padding = $self->extra_right_padding;
424              
425             my $keystyle = $self->key_style;
426             my $empty_track_style = $self->empty_track_style;
427              
428             return unless $keystyle eq 'left' or $keystyle eq 'right';
429             return unless $self->auto_pad;
430              
431             $self->setup_fonts();
432             my $width = $self->{key_font}->width;
433              
434             my $key = $self->track2key($track);
435             return unless defined $key;
436              
437             my $has_parts = $track->parts;
438             next if !$has_parts && $empty_track_style eq 'suppress';
439              
440             my $width_needed = $self->{key_font}->width * CORE::length($key)+3;
441             if ($keystyle eq 'left') {
442             my $width_i_have = $self->pad_left;
443             $self->pad_left($width_needed) if $width_needed > $width_i_have;
444             } elsif ($keystyle eq 'right') {
445             $width_needed += $extra_padding;
446             my $width_i_have = $self->pad_right;
447             $self->pad_right($width_needed) if $width_needed > $width_i_have;
448             }
449             }
450              
451             sub extra_right_padding { EXTRA_RIGHT_PADDING }
452              
453             sub height {
454             my $self = shift;
455             $self->setup_fonts;
456              
457             for my $track (@{$self->{tracks}}) {
458             $self->_expand_padding($track);
459             }
460              
461             my $spacing = $self->spacing;
462             my $key_height = $self->format_key;
463             my $empty_track_style = $self->empty_track_style;
464             my $key_style = $self->key_style;
465             my $bottom_key = $key_style eq 'bottom';
466             my $between_key = $key_style eq 'between';
467             my $side_key = $key_style =~ /left|right/;
468             my $draw_empty = $empty_track_style =~ /^(line|dashed)$/;
469             my $keyheight = $self->{key_font}->height;
470             my $height = 0;
471             for my $track (@{$self->{tracks}}) {
472             my $draw_between = $between_key && $track->option('key');
473             my $has_parts = $track->parts;
474             next if !$has_parts && ($empty_track_style eq 'suppress'
475             or $empty_track_style eq 'key' && $bottom_key);
476             $height += $keyheight if $draw_between;
477             $height += $self->spacing;
478             my $layout_height = $track->layout_height;
479             $height += ($side_key && $keyheight > $layout_height) ? $keyheight : $layout_height;
480             }
481              
482             # get rid of spacing under last track
483             $height -= $self->spacing unless $bottom_key;
484             return $height + $key_height + $self->pad_top + $self->pad_bottom + 2;
485             }
486              
487             sub setup_fonts {
488             my $self = shift;
489             return if ref $self->{key_font};
490              
491             my $image_class = $self->image_class;
492             my $keyfont = $self->{key_font};
493             my $font_obj = $image_class->$keyfont;
494             $self->{key_font} = $font_obj;
495             }
496              
497             sub gd {
498             my $self = shift;
499             my $existing_gd = shift;
500              
501             local $^W = 0; # can't track down the uninitialized variable warning
502              
503             return $self->{gd} if $self->{gd};
504              
505             $self->setup_fonts;
506              
507             unless ($existing_gd) {
508             my $image_class = $self->image_class;
509             eval "require $image_class; 1" or $self->throw($@);
510             }
511              
512             my $height = $self->height;
513             my $width = $self->width + $self->pad_left + $self->pad_right;
514              
515             my $pkg = $self->image_package;
516              
517             $height = 12 if $height < 1; # so GD doesn't crash
518             $width = 1 if $width < 1; # ditto
519              
520             my $gd = $existing_gd || $pkg->new($width,$height,
521             ($self->{truecolor} && $pkg->can('isTrueColor') ? 1 : ())
522             );
523             $gd->{debug} = 0 if $gd->isa('GD::SVG::Image'); # hack
524             $self->{gd} = $gd;
525              
526             if ($self->{truecolor}
527             && $pkg->can('saveAlpha')) {
528             $gd->saveAlpha(1);
529             }
530              
531             my %translation_table;
532             my $global_alpha = $self->{global_alpha} || 0;
533             for my $name (keys %COLORS) {
534             my $idx = $gd->colorAllocate(@{$COLORS{$name}});
535             $translation_table{$name} = $idx;
536             }
537              
538             $self->{translations} = \%translation_table;
539             $self->{gd} = $gd->isa('GD::SVG::Image') ? $gd
540             : $self->truetype ? Bio::Graphics::GDWrapper->new($gd,$self->truetype)
541             : $gd;
542            
543             eval {$gd->alphaBlending(0)};
544             if ($self->bgcolor) {
545             $gd->fill(0,0,$self->bgcolor);
546             } elsif (eval {$gd->isTrueColor}) {
547             $gd->fill(0,0,$translation_table{'white'});
548             }
549             eval {$gd->alphaBlending(1)};
550              
551             my $pl = $self->pad_left;
552             my $pt = $self->pad_top;
553             my $offset = $pt;
554             my $keyheight = $self->{key_font}->height;
555             my $bottom_key = $self->{key_style} eq 'bottom';
556             my $between_key = $self->{key_style} eq 'between';
557             my $left_key = $self->{key_style} eq 'left';
558             my $right_key = $self->{key_style} eq 'right';
559             my $empty_track_style = $self->empty_track_style;
560             my $spacing = $self->spacing;
561              
562             # we draw in two steps, once for background of tracks, and once for
563             # the contents. This allows the grid to sit on top of the track background.
564             for my $track (@{$self->{tracks}}) {
565             my $draw_between = $between_key && $track->option('key');
566             next if !$track->parts && ($empty_track_style eq 'suppress'
567             or $empty_track_style eq 'key' && $bottom_key);
568             $gd->filledRectangle($pl,
569             $offset,
570             $width-$self->pad_right,
571             $offset+$track->layout_height
572             + ($between_key ? $self->{key_font}->height : 0),
573             $track->tkcolor)
574             if defined $track->tkcolor;
575             $offset += $keyheight if $draw_between;
576             $offset += $track->layout_height + $spacing;
577             }
578              
579             $self->startGroup($gd);
580             $self->draw_background($gd,$self->{background}) if $self->{background};
581             $self->draw_grid($gd) if $self->{grid};
582             $self->draw_background($gd,$self->{postgrid}) if $self->{postgrid};
583             $self->endGroup($gd);
584              
585             $offset = $pt;
586             for my $track (@{$self->{tracks}}) {
587             $self->startGroup($gd);
588             my $draw_between = $between_key && $track->option('key');
589             my $has_parts = $track->parts;
590             my $side_key_height = 0;
591              
592             next if !$has_parts && ($empty_track_style eq 'suppress'
593             or $empty_track_style eq 'key' && $bottom_key);
594              
595             if ($draw_between) {
596             $offset += $self->draw_between_key($gd,$track,$offset);
597             }
598              
599             $self->draw_empty($gd,$offset,$empty_track_style)
600             if !$has_parts && $empty_track_style=~/^(line|dashed)$/;
601              
602             $track->draw($gd,$pl,$offset,0,1);
603              
604             if ($self->{key_style} =~ /^(left|right)$/) {
605             $side_key_height = $self->draw_side_key($gd,$track,$offset,$self->{key_style});
606             }
607              
608             $self->track_position($track,$offset);
609             my $layout_height = $track->layout_height;
610             $offset += ($side_key_height > $layout_height ? $side_key_height : $layout_height)+$spacing;
611              
612             $self->endGroup($gd);
613             }
614              
615              
616             $self->startGroup($gd);
617             $self->draw_bottom_key($gd,$pl,$offset) if $self->{key_style} eq 'bottom';
618             $self->endGroup($gd);
619              
620             return $self->{gd} = $self->rotate ? $gd->copyRotate90 : $gd;
621             }
622              
623             sub gdfont {
624             my $self = shift;
625             my $font = shift;
626             my $img_class = $self->image_class;
627              
628             if (!UNIVERSAL::isa($font,$img_class . '::Font') && $font =~ /^(gd|sanserif)/) {
629             my $ref = $self->{gdfonts} ||= {
630             gdTinyFont => $img_class->gdTinyFont(),
631             gdSmallFont => $img_class->gdSmallFont(),
632             gdMediumBoldFont => $img_class->gdMediumBoldFont(),
633             gdLargeFont => $img_class->gdLargeFont(),
634             gdGiantFont => $img_class->gdGiantFont(),
635             sanserif => $img_class->gdSmallFont(),
636             };
637             return $ref->{$font} || $ref->{gdSmallFont};
638             } else {
639             return $font;
640             }
641             }
642              
643             sub string_width {
644             my $self = shift;
645             my ($font,$string) = @_;
646              
647             my $class = $self->image_class;
648              
649             return $font->width*CORE::length($string)
650             unless $self->truetype && $class ne 'GD::SVG';
651             return Bio::Graphics::GDWrapper->string_width($font,$string);
652             }
653              
654             sub string_height {
655             my $self = shift;
656             my ($font,$string) = @_;
657              
658             my $class = $self->image_class;
659              
660             return $font->height
661             unless $self->truetype
662             && eval{$class eq 'GD' || $class->isa('GD::Image')};
663              
664             return Bio::Graphics::GDWrapper->string_height($font,$string);
665             }
666              
667             sub startGroup {
668             my $self = shift;
669             my $gd = shift;
670             $gd->startGroup if $gd->can('startGroup');
671             }
672              
673             sub endGroup {
674             my $self = shift;
675             my $gd = shift;
676             $gd->endGroup if $gd->can('endGroup');
677             }
678              
679              
680             # Package accessors
681             # GD (and GD::SVG)'s new() resides in GD::Image
682             sub image_class { return shift->{image_class}; }
683             sub image_package { return shift->{image_package}; }
684             sub polygon_package { return shift->{polygon_package}; }
685              
686             sub boxes {
687             my $self = shift;
688              
689             if (my $boxes = $self->{boxes}){ # cached result
690             return wantarray ? @$boxes : $boxes;
691             }
692              
693             my @boxes;
694             my $offset = 0;
695              
696             $self->setup_fonts;
697              
698             my $pl = $self->pad_left;
699             my $pt = $self->pad_top;
700              
701             my $between_key = $self->{key_style} eq 'between';
702             my $bottom_key = $self->{key_style} eq 'bottom';
703             my $empty_track_style = $self->empty_track_style;
704             my $keyheight = $self->{key_font}->height;
705             my $spacing = $self->spacing;
706             my $rotate = $self->rotate;
707              
708             for my $track (@{$self->{tracks}}) {
709             my $draw_between = $between_key && $track->option('key');
710             next if !$track->parts && ($empty_track_style eq 'suppress'
711             or $empty_track_style eq 'key' && $bottom_key);
712             $offset += $keyheight if $draw_between;
713             my $height = $track->layout_height;
714             my $boxes = $track->boxes($pl,$offset+$pt);
715             $self->track_position($track,$offset);
716             push @boxes,@$boxes;
717             $offset += $track->layout_height + $self->spacing;
718             }
719              
720             if ($rotate) {
721             my $x_offset = $self->height-1;
722             @boxes = map {
723             @{$_}[1,2,3,4] = @{$_}[4,1,2,3];
724             ($_->[1],$_->[3]) = map {$x_offset - $_} @{$_}[1,3];
725             $_;
726             } @boxes;
727             }
728             $self->{boxes} = \@boxes;
729             return wantarray ? @boxes : \@boxes;
730             }
731              
732             sub track_position {
733             my $self = shift;
734             my $track = shift;
735             my $d = $self->{_track_position}{$track};
736             $self->{_track_position}{$track} = shift if @_;
737             $d;
738             }
739              
740             # draw the keys -- between
741             sub draw_between_key {
742             my $self = shift;
743             my ($gd,$track,$offset) = @_;
744             my $key = $self->track2key($track) or return 0;
745             my $x = $self->{key_align} eq 'center' ? $self->width - (CORE::length($key) * $self->{key_font}->width)/2
746             : $self->{key_align} eq 'right' ? $self->width - CORE::length($key)
747             : $self->pad_left;
748              
749             # Key color hard-coded. Should be configurable for the control freaks.
750             my $color = $self->translate_color('black');
751             $gd->string($self->{key_font},$x,$offset,$key,$color) unless $self->{suppress_key};
752             $self->add_key_box($track,$key,$x,$offset);
753             return $self->{key_font}->height;
754             }
755              
756             # draw the keys -- left or right side
757             sub draw_side_key {
758             my $self = shift;
759             my ($gd,$track,$offset,$side) = @_;
760             my $key = $self->track2key($track) or return;
761             my $pos = $side eq 'left' ? $self->pad_left - $self->{key_font}->width * CORE::length($key)-3
762             : $self->pad_left + $self->width + EXTRA_RIGHT_PADDING;
763             my $color = $self->translate_color('black');
764             unless ($self->{suppress_key}) {
765             $gd->filledRectangle($pos,$offset,
766             $pos+$self->{key_font}->width*CORE::length($key),$offset,#-$self->{key_font}->height)/2,
767             $self->bgcolor);
768             $gd->string($self->{key_font},$pos,$offset,$key,$color);
769             }
770             $self->add_key_box($track,$key,$pos,$offset);
771             return $self->{key_font}->height;
772             }
773              
774             # draw the keys -- bottom
775             sub draw_bottom_key {
776             my $self = shift;
777             my ($gd,$left,$top) = @_;
778             my $key_glyphs = $self->{key_glyphs} or return;
779              
780             my $color = $self->translate_color($self->{key_color});
781             $gd->filledRectangle($left,$top,$self->width - $self->pad_right,$self->height-$self->pad_bottom,$color);
782             my $text_color = $self->translate_color('black');
783             $gd->string($self->{key_font},$left,KEYPADTOP+$top,"KEY:",$text_color) unless $self->{suppress_key};
784             $top += $self->{key_font}->height + KEYPADTOP;
785             $_->draw($gd,$left,$top) foreach @$key_glyphs;
786             }
787              
788             # Format the key section, and return its height
789             sub format_key {
790             my $self = shift;
791             return 0 unless $self->key_style eq 'bottom';
792              
793             return $self->{key_height} if defined $self->{key_height};
794              
795             my $suppress = $self->{empty_track_style} eq 'suppress';
796             my $between = $self->{key_style} eq 'between';
797              
798             if ($between) {
799             my @key_tracks = $suppress
800             ? grep {$_->option('key') && $_->parts} @{$self->{tracks}}
801             : grep {$_->option('key')} @{$self->{tracks}};
802             return $self->{key_height} = @key_tracks * $self->{key_font}->height;
803             }
804              
805             elsif ($self->{key_style} eq 'bottom') {
806              
807             my ($height,$width) = (0,0);
808             my %tracks;
809             my @glyphs;
810             local $self->{flip} = 0; # don't want to worry about flipped keys!
811              
812             # determine how many glyphs become part of the key
813             # and their max size
814             for my $track (@{$self->{tracks}}) {
815              
816             next unless $track->option('key');
817             next if $suppress && !$track->parts;
818              
819             my $glyph;
820             if (my @parts = $track->parts) {
821             $glyph = $parts[0]->keyglyph;
822             } else {
823             my $t = Bio::Graphics::Feature->new(-segments=>
824             [Bio::Graphics::Feature->new(-start => $self->offset,
825             -stop => $self->offset+$self->length)]);
826             my $g = $track->factory->make_glyph(0,$t);
827             $glyph = $g->keyglyph;
828             }
829             next unless $glyph;
830              
831              
832             $tracks{$track} = $glyph;
833             my ($h,$w) = ($glyph->layout_height,
834             $glyph->layout_width);
835             $height = $h if $h > $height;
836             $width = $w if $w > $width;
837             push @glyphs,$glyph;
838              
839             }
840              
841             $width += $self->key_spacing;
842              
843             # no key glyphs, no key
844             return $self->{key_height} = 0 unless @glyphs;
845              
846             # now height and width hold the largest glyph, and $glyph_count
847             # contains the number of glyphs. We will format them into a
848             # box that is roughly 3 height/4 width (golden mean)
849             my $rows = 0;
850             my $cols = 0;
851             my $maxwidth = $self->width - $self->pad_left - $self->pad_right;
852             while (++$rows) {
853             $cols = @glyphs / $rows;
854             $cols = int ($cols+1) if $cols =~ /\./; # round upward for fractions
855             my $total_width = $cols * $width;
856             my $total_height = $rows * $width;
857             last if $total_width < $maxwidth;
858             }
859              
860             # move glyphs into row-major format
861             my $spacing = $self->key_spacing;
862             my $i = 0;
863             for (my $c = 0; $c < $cols; $c++) {
864             for (my $r = 0; $r < $rows; $r++) {
865             my $x = $c * ($width + $spacing);
866             my $y = $r * ($height + $spacing);
867             next unless defined $glyphs[$i];
868             $glyphs[$i]->move($x,$y);
869             $i++;
870             }
871             }
872              
873             $self->{key_glyphs} = \@glyphs; # remember our key glyphs
874             # remember our key height
875             return $self->{key_height} =
876             ($height+$spacing) * $rows + $self->{key_font}->height +KEYPADTOP;
877             }
878              
879             else { # no known key style, neither "between" nor "bottom"
880             return $self->{key_height} = 0;
881             }
882             }
883              
884             sub add_key_box {
885             my $self = shift;
886             my ($track,$label,$x,$y, $is_legend) = @_;
887             my $value = [$label,$x,$y,$x+$self->{key_font}->width*CORE::length($label),$y+$self->{key_font}->height,$track];
888             push @{$self->{key_boxes}},$value;
889             }
890              
891             sub key_boxes {
892             my $ref = shift->{key_boxes};
893             return wantarray ? @$ref : $ref;
894             }
895              
896             sub add_category_labels {
897             my $self = shift;
898             my $d = $self->{add_category_labels};
899             $self->{add_category_labels} = shift if @_;
900             $d;
901             }
902              
903             sub track2key {
904             my $self = shift;
905             my $track = shift;
906             return $track->make_key_name();
907             }
908              
909             sub draw_empty {
910             my $self = shift;
911             my ($gd,$offset,$style) = @_;
912             $offset += $self->spacing/2;
913             my $left = $self->pad_left;
914             my $right = $self->width-$self->pad_right;
915             my $color = $self->translate_color(MISSING_TRACK_COLOR);
916             my $ic = $self->image_class;
917             if ($style eq 'dashed') {
918             $gd->setStyle($color,$color,$ic->gdTransparent(),$ic->gdTransparent());
919             $gd->line($left,$offset,$right,$offset,$ic->gdStyled());
920             } else {
921             $gd->line($left,$offset,$right,$offset,$color);
922             }
923             $offset;
924             }
925              
926             # draw a grid
927             sub draw_grid {
928             my $self = shift;
929             my $gd = shift;
930              
931             my $gridcolor = $self->translate_color($self->{gridcolor});
932             my $gridmajorcolor = $self->translate_color($self->{gridmajorcolor});
933             my @positions;
934             my ($major,$minor);
935             if (ref $self->{grid} eq 'ARRAY') {
936             @positions = @{$self->{grid}};
937             } else {
938             ($major,$minor) = $self->ticks;
939             my $first_tick = $minor * int($self->start/$minor);
940             for (my $i = $first_tick; $i <= $self->end+1; $i += $minor) {
941             push @positions,$i;
942             }
943             }
944             my $pl = $self->pad_left;
945             my $pt = $self->extend_grid ? 0 : $self->pad_top;
946             my $pr = $self->right;
947             my $pb = $self->extend_grid ? $self->height : $self->height - $self->pad_bottom;
948             my $offset = $self->{offset}+$self->{length}+1;
949             for my $tick (@positions) {
950             my ($pos) = $self->map_pt($self->{flip} ? $offset - $tick
951             : $tick);
952             my $color = (defined $major && $tick % $major == 0) ? $gridmajorcolor : $gridcolor;
953             $gd->line($pl+$pos,$pt,$pl+$pos,$pb,$color);
954             }
955             }
956              
957             # draw an image (or invoke a drawing routine)
958             sub draw_background {
959             my $self = shift;
960             my ($gd,$image_or_routine) = @_;
961             if (ref $image_or_routine eq 'CODE') {
962             return $image_or_routine->($gd,$self);
963             }
964             if (-f $image_or_routine) { # a file to draw
965             my $method = $image_or_routine =~ /\.png$/i ? 'newFromPng'
966             : $image_or_routine =~ /\.jpe?g$/i ? 'newFromJpeg'
967             : $image_or_routine =~ /\.gd$/i ? 'newFromGd'
968             : $image_or_routine =~ /\.gif$/i ? 'newFromGif'
969             : $image_or_routine =~ /\.xbm$/i ? 'newFromXbm'
970             : '';
971             return unless $method;
972             my $image = eval {$self->image_package->$method($image_or_routine)};
973             unless ($image) {
974             warn $@;
975             return;
976             }
977             my ($src_width,$src_height) = $image->getBounds;
978             my ($dst_width,$dst_height) = $gd->getBounds;
979             # tile the thing on
980             for (my $x = 0; $x < $dst_width; $x += $src_width) {
981             for (my $y = 0; $y < $dst_height; $y += $src_height) {
982             $gd->copy($image,$x,$y,0,0,$src_width,$src_height);
983             }
984             }
985             }
986             }
987              
988             # calculate major and minor ticks, given a start position
989             sub ticks {
990             my $self = shift;
991             my ($length,$minwidth) = @_;
992              
993             my $img = $self->image_class;
994             $length = $self->{length} unless defined $length;
995             $minwidth = $img->gdSmallFont->width*7 unless defined $minwidth;
996              
997             my ($major,$minor);
998              
999             # figure out tick mark scale
1000             # we want no more than 1 major tick mark every 40 pixels
1001             # and enough room for the labels
1002             my $scale = $self->scale;
1003              
1004             my $interval = 10;
1005              
1006             while (1) {
1007             my $pixels = $interval * $scale;
1008             last if $pixels >= $minwidth;
1009             $interval *= 10;
1010             }
1011              
1012             # to make sure a major tick shows up somewhere in the first half
1013             #
1014             # $interval *= .5 if ($interval > 0.5*$length);
1015              
1016             return ($interval,$interval/10);
1017             }
1018              
1019             # reverse of translate(); given index, return rgb triplet
1020             sub rgb {
1021             my $self = shift;
1022             my $idx = shift;
1023             my $gd = $self->{gd} or return;
1024             return $gd->rgb($idx);
1025             }
1026              
1027             sub transparent_color {
1028             my $self = shift;
1029             my ($opacity,@colors) = @_;
1030             return $self->_translate_color($opacity,@colors);
1031             }
1032              
1033             sub translate_color {
1034             my $self = shift;
1035             my @colors = @_;
1036             return $self->_translate_color(1.0,@colors);
1037             }
1038              
1039             sub _translate_color {
1040             my $self = shift;
1041             my ($opacity,@colors) = @_;
1042             $opacity = '1.0' if $opacity == 1;
1043             my $default_alpha = $self->adjust_alpha($opacity);
1044             $default_alpha ||= 0;
1045              
1046             my $ckey = "@{colors}_${default_alpha}";
1047             return $self->{closestcache}{$ckey} if exists $self->{closestcache}{$ckey};
1048              
1049             my $index;
1050             my $gd = $self->gd or return 1;
1051             my $table = $self->{translations} or return 1;
1052              
1053             if (@colors == 3) {
1054             $index = $gd->colorAllocateAlpha(@colors,$default_alpha);
1055             }
1056             elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
1057             my ($r,$g,$b,$alpha) = (hex($1),hex($2),hex($3),hex($4));
1058             $index = $gd->colorAllocateAlpha($r,$g,$b,$alpha);
1059             }
1060             elsif ($colors[0] =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
1061             my ($r,$g,$b) = (hex($1),hex($2),hex($3));
1062             $index = $gd->colorAllocateAlpha($r,$g,$b,$default_alpha);
1063             }
1064             elsif ($colors[0] =~ /^(\d+),(\d+),(\d+),([\d.]+)$/i ||
1065             $colors[0] =~ /^rgba\((\d+),(\d+),(\d+),([\d.]+)\)$/) {
1066             my $alpha = $self->adjust_alpha($4);
1067             my (@rgb) = map {/(\d+)%/ ? int(255 * $1 / 100) : $_} ($1,$2,$3);
1068             $index = $gd->colorAllocateAlpha(@rgb,$4);
1069             }
1070             elsif ($colors[0] =~ /^(\d+),(\d+),(\d+)$/i ||
1071             $colors[0] =~ /^rgb\((\d+),(\d+),(\d+)\)$/i
1072             ) {
1073             my (@rgb) = map {/(\d+)%/ ? int(255 * $1 / 100) : $_} ($1,$2,$3);
1074             $index = $gd->colorAllocateAlpha(@rgb,$default_alpha);
1075             }
1076             elsif ($colors[0] eq 'transparent') {
1077             $index = $gd->colorAllocateAlpha(255,255,255,127);
1078             }
1079             elsif ($colors[0] =~ /^(\w+):([\d.]+)/) { # color:alpha
1080             my @rgb = $self->color_name_to_rgb($1);
1081             @rgb = (0,0,0) unless @rgb;
1082             my $alpha = $self->adjust_alpha($2);
1083             $index = $gd->colorAllocateAlpha(@rgb,$alpha);
1084             }
1085             elsif ($default_alpha < 127) {
1086             my @rgb = $self->color_name_to_rgb($colors[0]);
1087             @rgb = (0,0,0) unless @rgb;
1088             $index = $gd->colorAllocateAlpha(@rgb,$default_alpha);
1089             }
1090             else {
1091             $index = defined $table->{$colors[0]} ? $table->{$colors[0]} : 1;
1092             }
1093             return $self->{closestcache}{$ckey} = $index;
1094             }
1095              
1096             # change CSS opacity values (0-1.0) into GD opacity values (127-0)
1097             sub adjust_alpha {
1098             my $self = shift;
1099             my $value = shift;
1100             my $alpha = $value =~ /\./ # floating point
1101             ? int(127-($value*127)+0.5)
1102             : $value;
1103             $alpha = 0 if $alpha < 0;
1104             $alpha = 127 if $alpha > 127;
1105             return $alpha;
1106             }
1107              
1108             # workaround for bad GD
1109             sub colorClosest {
1110             my ($self,$gd,@c) = @_;
1111             return $gd->colorResolve(@c) if $GD::VERSION < 2.04;
1112              
1113             my $index = $gd->colorResolve(@c);
1114             return $index if $index >= 0;
1115              
1116             my $value;
1117             for (keys %COLORS) {
1118             my ($r,$g,$b) = @{$COLORS{$_}};
1119             my $dist = ($r-$c[0])**2 + ($g-$c[1])**2 + ($b-$c[2])**2;
1120             ($value,$index) = ($dist,$_) if !defined($value) || $dist < $value;
1121             }
1122             return $self->{translations}{$index};
1123             }
1124              
1125             sub bgcolor {
1126             my $self = shift;
1127             return unless $self->{bgcolor};
1128             return $self->translate_color($self->{bgcolor});
1129             }
1130              
1131             sub set_pen {
1132             my $self = shift;
1133             my ($linewidth,$color) = @_;
1134             return $self->{pens}{$linewidth,$color} if $self->{pens}{$linewidth,$color};
1135             my $gd = $self->{gd};
1136             my $pkg = $self->image_package;
1137             my $pen = $self->{pens}{$linewidth} = $pkg->new($linewidth,$linewidth);
1138             my @rgb = $self->rgb($color);
1139             my $bg = $pen->colorAllocate(255,255,255);
1140             my $fg = $pen->colorAllocate(@rgb);
1141             $pen->fill(0,0,$fg);
1142             $gd->setBrush($pen);
1143             return $self->image_class->gdBrushed();
1144             }
1145              
1146             sub png {
1147             my $gd = shift->gd;
1148             $gd->png;
1149             }
1150              
1151             sub svg {
1152             my $gd = shift->gd;
1153             $gd->svg;
1154             }
1155              
1156              
1157             # WARNING: THIS STUFF IS COPIED FROM Bio::Graphics::Browser.pm AND
1158             # Bio::Graphics::FeatureFile AND MUST BE REFACTORED
1159             # write a png image to disk and generate an image map in a convenient
1160             # CGIish way.
1161             sub image_and_map {
1162             my $self = shift;
1163             my %args = @_;
1164             my $link_rule = $args{-link} || $self->{linkrule};
1165             my $title_rule = $args{-title} || $self->{titlerule};
1166             my $target_rule = $args{-target} || $self->{targetrule};
1167             my $tmpurl = $args{-url} || '/tmp';
1168             my $docroot = $args{-root} || $ENV{DOCUMENT_ROOT} || '';
1169             my $mapname = $args{-mapname} || $IMAGEMAP++;
1170             $docroot .= '/' if $docroot && $docroot !~ m!/$!;
1171              
1172             # get rid of any netstat part please
1173             (my $tmpurlbase = $tmpurl) =~ s!^\w+://[^/]+!!;
1174              
1175             my $tmpdir = "${docroot}${tmpurlbase}";
1176              
1177             my $url = $self->create_web_image($tmpurl,$tmpdir);
1178             my $map = $self->create_web_map($mapname,$link_rule,$title_rule,$target_rule);
1179             return ($url,$map,$mapname);
1180             }
1181              
1182             sub create_web_image {
1183             my $self = shift;
1184             my ($tmpurl,$tmpdir) = @_;
1185              
1186             # create directory if it isn't there already
1187             # we need to untaint tmpdir before calling mkpath()
1188             return unless $tmpdir =~ /^(.+)$/;
1189             my $path = $1;
1190             unless (-d $path) {
1191             require File::Path unless defined &File::Path::mkpath;
1192             File::Path::mkpath($path,0,0777) or $self->throw("Couldn't create temporary image directory $path: $!");
1193             }
1194              
1195             unless (defined &Digest::MD5::md5_hex) {
1196             eval "require Digest::MD5; 1"
1197             or $self->throw("Sorry, but the image_and_map() method requires the Digest::MD5 module.");
1198             }
1199             my $data = $self->png;
1200             my $signature = Digest::MD5::md5_hex($data);
1201             my $extension = 'png';
1202              
1203             # untaint signature for use in open
1204             $signature =~ /^([0-9A-Fa-f]+)$/g or return;
1205             $signature = $1;
1206              
1207             my $url = sprintf("%s/%s.%s",$tmpurl,$signature,$extension);
1208             my $imagefile = sprintf("%s/%s.%s",$tmpdir,$signature,$extension);
1209              
1210             open (my $F,">", $imagefile) || $self->throw("Can't open image file $imagefile for writing: $!\n");
1211             binmode($F);
1212             print $F $data;
1213              
1214             return $url;
1215             }
1216              
1217             sub create_web_map {
1218             my $self = shift;
1219             my ($name,$linkrule,$titlerule,$targetrule) = @_;
1220             $name ||= 'map';
1221             my $boxes = $self->boxes;
1222             my (%track2link,%track2title,%track2target);
1223              
1224             eval "require CGI" unless CGI->can('escapeHTML');
1225              
1226             my $map = qq(<map name="$name" id="$name">\n);
1227             foreach (@$boxes){
1228             my ($feature,$left,$top,$right,$bottom,$track) = @$_;
1229             next unless $feature->can('primary_tag');
1230              
1231             my $lr = $track2link{$track} ||= (defined $track->option('link') ? $track->option('link') : $linkrule);
1232             next unless $lr;
1233              
1234             my $tr = exists $track2title{$track}
1235             ? $track2title{$track}
1236             : $track2title{$track} ||= (defined $track->option('title') ? $track->option('title') : $titlerule);
1237             my $tgr = exists $track2target{$track}
1238             ? $track2target{$track}
1239             : $track2target{$track} ||= (defined $track->option('target')? $track->option('target') : $targetrule);
1240              
1241             my $href = $self->make_link($lr,$feature);
1242             my $title = CGI::escapeHTML($self->make_link($tr,$feature,1));
1243             my $target = CGI::escapeHTML($self->make_link($tgr,$feature,1));
1244              
1245              
1246             my $a = $title ? qq(title="$title") : '';
1247             my $t = $target ? qq(target="$target") : '';
1248             $map .= qq(<area shape="rect" coords="$left,$top,$right,$bottom" href="$href" $a $t/>\n) if $href;
1249             }
1250             $map .= "</map>\n";
1251             $map;
1252             }
1253              
1254             sub make_link {
1255             my $self = shift;
1256             my ($linkrule,$feature,$escapeHTML) = @_;
1257             eval "require Bio::Graphics::FeatureFile;1"
1258             unless Bio::Graphics::FeatureFile->can('link_pattern');
1259             return Bio::Graphics::FeatureFile->link_pattern($linkrule,$feature,$self,$escapeHTML);
1260             }
1261              
1262             sub make_title {
1263             my $self = shift;
1264             my $feature = shift;
1265             eval "require Bio::Graphics::FeatureFile;1"
1266             unless Bio::Graphics::FeatureFile->can('make_title');
1267             return Bio::Graphics::FeatureFile->make_title($feature);
1268             }
1269              
1270             sub read_colors {
1271             my $class = shift;
1272             local ($/) = "\n";
1273             local $_;
1274             while (<DATA>) {
1275             chomp;
1276             last if /^__END__/;
1277             my ($name,$r,$g,$b) = split /\s+/;
1278             @{$COLORS{$name}} = (hex $r,hex $g, hex $b);
1279             }
1280             }
1281              
1282             sub color_name_to_rgb {
1283             my $class = shift;
1284             my $color_name = shift;
1285             $class->read_colors() unless %COLORS;
1286             return unless $COLORS{$color_name};
1287             return wantarray ? @{$COLORS{$color_name}}
1288             : $COLORS{$color_name};
1289             }
1290              
1291             sub color_names {
1292             my $class = shift;
1293             $class->read_colors unless %COLORS;
1294             return wantarray ? keys %COLORS : [keys %COLORS];
1295             }
1296              
1297             sub glyph_scratch {
1298             my $self = shift;
1299             my $d = $GlyphScratch;
1300             $GlyphScratch = shift if @_;
1301             $d;
1302             }
1303              
1304             sub finished {
1305             my $self = shift;
1306             for my $track (@{$self->{tracks} || []}) {
1307             $track->finished();
1308             }
1309             delete $self->{tracks};
1310             }
1311              
1312             1;
1313              
1314             __DATA__
1315             white FF FF FF
1316             black 00 00 00
1317             aliceblue F0 F8 FF
1318             antiquewhite FA EB D7
1319             aqua 00 FF FF
1320             aquamarine 7F FF D4
1321             azure F0 FF FF
1322             beige F5 F5 DC
1323             bisque FF E4 C4
1324             blanchedalmond FF EB CD
1325             blue 00 00 FF
1326             blueviolet 8A 2B E2
1327             brown A5 2A 2A
1328             burlywood DE B8 87
1329             cadetblue 5F 9E A0
1330             chartreuse 7F FF 00
1331             chocolate D2 69 1E
1332             coral FF 7F 50
1333             cornflowerblue 64 95 ED
1334             cornsilk FF F8 DC
1335             crimson DC 14 3C
1336             cyan 00 FF FF
1337             darkblue 00 00 8B
1338             darkcyan 00 8B 8B
1339             darkgoldenrod B8 86 0B
1340             darkgray A9 A9 A9
1341             darkgreen 00 64 00
1342             darkkhaki BD B7 6B
1343             darkmagenta 8B 00 8B
1344             darkolivegreen 55 6B 2F
1345             darkorange FF 8C 00
1346             darkorchid 99 32 CC
1347             darkred 8B 00 00
1348             darksalmon E9 96 7A
1349             darkseagreen 8F BC 8F
1350             darkslateblue 48 3D 8B
1351             darkslategray 2F 4F 4F
1352             darkturquoise 00 CE D1
1353             darkviolet 94 00 D3
1354             deeppink FF 14 100
1355             deepskyblue 00 BF FF
1356             dimgray 69 69 69
1357             dodgerblue 1E 90 FF
1358             firebrick B2 22 22
1359             floralwhite FF FA F0
1360             forestgreen 22 8B 22
1361             fuchsia FF 00 FF
1362             gainsboro DC DC DC
1363             ghostwhite F8 F8 FF
1364             gold FF D7 00
1365             goldenrod DA A5 20
1366             gray 80 80 80
1367             grey 80 80 80
1368             green 00 80 00
1369             greenyellow AD FF 2F
1370             honeydew F0 FF F0
1371             hotpink FF 69 B4
1372             indianred CD 5C 5C
1373             indigo 4B 00 82
1374             ivory FF FF F0
1375             khaki F0 E6 8C
1376             lavender E6 E6 FA
1377             lavenderblush FF F0 F5
1378             lawngreen 7C FC 00
1379             lemonchiffon FF FA CD
1380             lightblue AD D8 E6
1381             lightcoral F0 80 80
1382             lightcyan E0 FF FF
1383             lightgoldenrodyellow FA FA D2
1384             lightgreen 90 EE 90
1385             lightgrey D3 D3 D3
1386             lightpink FF B6 C1
1387             lightsalmon FF A0 7A
1388             lightseagreen 20 B2 AA
1389             lightskyblue 87 CE FA
1390             lightslategray 77 88 99
1391             lightsteelblue B0 C4 DE
1392             lightyellow FF FF E0
1393             lime 00 FF 00
1394             limegreen 32 CD 32
1395             linen FA F0 E6
1396             magenta FF 00 FF
1397             maroon 80 00 00
1398             mediumaquamarine 66 CD AA
1399             mediumblue 00 00 CD
1400             mediumorchid BA 55 D3
1401             mediumpurple 100 70 DB
1402             mediumseagreen 3C B3 71
1403             mediumslateblue 7B 68 EE
1404             mediumspringgreen 00 FA 9A
1405             mediumturquoise 48 D1 CC
1406             mediumvioletred C7 15 85
1407             midnightblue 19 19 70
1408             mintcream F5 FF FA
1409             mistyrose FF E4 E1
1410             moccasin FF E4 B5
1411             navajowhite FF DE AD
1412             navy 00 00 80
1413             oldlace FD F5 E6
1414             olive 80 80 00
1415             olivedrab 6B 8E 23
1416             orange FF A5 00
1417             orangered FF 45 00
1418             orchid DA 70 D6
1419             palegoldenrod EE E8 AA
1420             palegreen 98 FB 98
1421             paleturquoise AF EE EE
1422             palevioletred DB 70 100
1423             papayawhip FF EF D5
1424             peachpuff FF DA B9
1425             peru CD 85 3F
1426             pink FF C0 CB
1427             plum DD A0 DD
1428             powderblue B0 E0 E6
1429             purple 80 00 80
1430             red FF 00 00
1431             rosybrown BC 8F 8F
1432             royalblue 41 69 E1
1433             saddlebrown 8B 45 13
1434             salmon FA 80 72
1435             sandybrown F4 A4 60
1436             seagreen 2E 8B 57
1437             seashell FF F5 EE
1438             sienna A0 52 2D
1439             silver C0 C0 C0
1440             skyblue 87 CE EB
1441             slateblue 6A 5A CD
1442             slategray 70 80 90
1443             snow FF FA FA
1444             springgreen 00 FF 7F
1445             steelblue 46 82 B4
1446             tan D2 B4 8C
1447             teal 00 80 80
1448             thistle D8 BF D8
1449             tomato FF 63 47
1450             turquoise 40 E0 D0
1451             violet EE 82 EE
1452             wheat F5 DE B3
1453             whitesmoke F5 F5 F5
1454             yellow FF FF 00
1455             yellowgreen 9A CD 32
1456             gradient1 00 ff 00
1457             gradient2 0a ff 00
1458             gradient3 14 ff 00
1459             gradient4 1e ff 00
1460             gradient5 28 ff 00
1461             gradient6 32 ff 00
1462             gradient7 3d ff 00
1463             gradient8 47 ff 00
1464             gradient9 51 ff 00
1465             gradient10 5b ff 00
1466             gradient11 65 ff 00
1467             gradient12 70 ff 00
1468             gradient13 7a ff 00
1469             gradient14 84 ff 00
1470             gradient15 8e ff 00
1471             gradient16 99 ff 00
1472             gradient17 a3 ff 00
1473             gradient18 ad ff 00
1474             gradient19 b7 ff 00
1475             gradient20 c1 ff 00
1476             gradient21 cc ff 00
1477             gradient22 d6 ff 00
1478             gradient23 e0 ff 00
1479             gradient24 ea ff 00
1480             gradient25 f4 ff 00
1481             gradient26 ff ff 00
1482             gradient27 ff f4 00
1483             gradient28 ff ea 00
1484             gradient29 ff e0 00
1485             gradient30 ff d6 00
1486             gradient31 ff cc 00
1487             gradient32 ff c1 00
1488             gradient33 ff b7 00
1489             gradient34 ff ad 00
1490             gradient35 ff a3 00
1491             gradient36 ff 99 00
1492             gradient37 ff 8e 00
1493             gradient38 ff 84 00
1494             gradient39 ff 7a 00
1495             gradient40 ff 70 00
1496             gradient41 ff 65 00
1497             gradient42 ff 5b 00
1498             gradient43 ff 51 00
1499             gradient44 ff 47 00
1500             gradient45 ff 3d 00
1501             gradient46 ff 32 00
1502             gradient47 ff 28 00
1503             gradient48 ff 1e 00
1504             gradient49 ff 14 00
1505             gradient50 ff 0a 00
1506             __END__
1507              
1508             =head1 NAME
1509              
1510             Bio::Graphics::Panel - Generate GD images of Bio::Seq objects
1511              
1512             =head1 SYNOPSIS
1513              
1514             # This script parses a GenBank or EMBL file named on the command
1515             # line and produces a PNG rendering of it. Call it like this:
1516             # render.pl my_file.embl | display -
1517              
1518             use strict;
1519             use Bio::Graphics;
1520             use Bio::SeqIO;
1521              
1522             my $file = shift or die "provide a sequence file as the argument";
1523             my $io = Bio::SeqIO->new(-file=>$file) or die "could not create Bio::SeqIO";
1524             my $seq = $io->next_seq or die "could not find a sequence in the file";
1525              
1526             my @features = $seq->all_SeqFeatures;
1527              
1528             # sort features by their primary tags
1529             my %sorted_features;
1530             for my $f (@features) {
1531             my $tag = $f->primary_tag;
1532             push @{$sorted_features{$tag}},$f;
1533             }
1534              
1535             my $panel = Bio::Graphics::Panel->new(
1536             -length => $seq->length,
1537             -key_style => 'between',
1538             -width => 800,
1539             -pad_left => 10,
1540             -pad_right => 10,
1541             );
1542             $panel->add_track( arrow => Bio::SeqFeature::Generic->new(-start=>1,
1543             -end=>$seq->length),
1544             -bump => 0,
1545             -double=>1,
1546             -tick => 2);
1547             $panel->add_track(generic => Bio::SeqFeature::Generic->new(-start=>1,
1548             -end=>$seq->length),
1549             -glyph => 'generic',
1550             -bgcolor => 'blue',
1551             -label => 1,
1552             );
1553              
1554             # general case
1555             my @colors = qw(cyan orange blue purple green chartreuse magenta yellow aqua);
1556             my $idx = 0;
1557             for my $tag (sort keys %sorted_features) {
1558             my $features = $sorted_features{$tag};
1559             $panel->add_track($features,
1560             -glyph => 'generic',
1561             -bgcolor => $colors[$idx++ % @colors],
1562             -fgcolor => 'black',
1563             -font2color => 'red',
1564             -key => "${tag}s",
1565             -bump => +1,
1566             -height => 8,
1567             -label => 1,
1568             -description => 1,
1569             );
1570             }
1571              
1572             print $panel->png;
1573             $panel->finished;
1574              
1575             exit 0;
1576              
1577             =head1 DESCRIPTION
1578              
1579             The Bio::Graphics::Panel class provides drawing and formatting
1580             services for any object that implements the Bio::SeqFeatureI
1581             interface, including Ace::Sequence::Feature and Das::Segment::Feature
1582             objects. It can be used to draw sequence annotations, physical
1583             (contig) maps, or any other type of map in which a set of discrete
1584             ranges need to be laid out on the number line.
1585              
1586             The module supports a drawing style in which each type of feature
1587             occupies a discrete "track" that spans the width of the display. Each
1588             track will have its own distinctive "glyph", a configurable graphical
1589             representation of the feature.
1590              
1591             The module also supports a more flexible style in which several
1592             different feature types and their associated glyphs can occupy the
1593             same track. The choice of glyph is under run-time control.
1594              
1595             Semantic zooming (for instance, changing the type of glyph depending
1596             on the density of features) is supported by a callback system for
1597             configuration variables. The module has built-in support for Bio::Das
1598             stylesheets, and stylesheet-driven configuration can be intermixed
1599             with semantic zooming, if desired.
1600              
1601             You can add a key to the generated image using either of two key
1602             styles. One style places the key captions at the top of each track.
1603             The other style generates a graphical key at the bottom of the image.
1604              
1605             Note that this module depends on GD. The optional SVG output depends
1606             on GD::SVG and SVG.
1607              
1608             The installed script glyph_help.pl provides quick help on glyphs and
1609             their options.
1610              
1611             =head1 METHODS
1612              
1613             This section describes the class and object methods for
1614             Bio::Graphics::Panel.
1615              
1616             Typically you will begin by creating a new Bio::Graphics::Panel
1617             object, passing it the desired width of the image to generate and an
1618             origin and length describing the coordinate range to display. The
1619             Bio::Graphics::Panel-E<gt>new() method has many configuration variables
1620             that allow you to control the appearance of the image.
1621              
1622             You will then call add_track() one or more times to add sets of
1623             related features to the picture. add_track() places a new horizontal
1624             track on the image, and is likewise highly configurable. When you
1625             have added all the features you desire, you may call png() to convert
1626             the image into a PNG-format image, or boxes() to return coordinate
1627             information that can be used to create an imagemap.
1628              
1629             =head2 CONSTRUCTORS
1630              
1631             new() is the constructor for Bio::Graphics::Panel:
1632              
1633             =over 4
1634              
1635             =item $panel = Bio::Graphics::Panel-E<gt>new(@options)
1636              
1637             The new() method creates a new panel object. The options are
1638             a set of tag/value pairs as follows:
1639              
1640             Option Value Default
1641             ------ ----- -------
1642              
1643             -offset Base pair to place at extreme left none
1644             of image, in zero-based coordinates
1645              
1646             -length Length of sequence segment, in bp none
1647              
1648             -start Start of range, in 1-based none
1649             coordinates.
1650              
1651             -stop Stop of range, in 1-based none
1652             coordinates.
1653              
1654             -end Same as -stop.
1655              
1656             -segment A Bio::SeqI or Das::Segment none
1657             object, used to derive sequence
1658             range if not otherwise specified.
1659              
1660             -width Desired width of image, in pixels 600
1661              
1662             -spacing Spacing between tracks, in pixels 5
1663              
1664             -pad_top Additional whitespace between top 0
1665             of image and contents, in pixels
1666              
1667             -pad_bottom Additional whitespace between top 0
1668             of image and bottom, in pixels
1669              
1670             -pad_left Additional whitespace between left 0
1671             of image and contents, in pixels
1672              
1673             -pad_right Additional whitespace between right 0
1674             of image and bottom, in pixels
1675              
1676             -bgcolor Background color for the panel as a white
1677             whole
1678              
1679             -key_color Background color for the key printed wheat
1680             at bottom of panel (if any)
1681              
1682             -key_spacing Spacing between key glyphs in the 10
1683             key printed at bottom of panel
1684             (if any)
1685              
1686             -key_font Font to use in printed key gdMediumBoldFont
1687             captions.
1688              
1689             -key_style Whether to print key at bottom of none
1690             panel ("bottom"), between each
1691             track ("between"), to the left of
1692             each track ("left"), to the right
1693             of each track ("right") or
1694             not at all ("none").
1695              
1696             -add_category_labels false
1697             Whether to add the "category" to
1698             the track key. The category is
1699             an optional argument that can
1700             be attached to each track. If
1701             a category is present, and this
1702             option is true, then the category
1703             will be added to the track label
1704             in parentheses. For example, if
1705             -key is "Protein matches" and
1706             -category is "vertebrate", then
1707             the track will be labeled
1708             "Protein matches (vertebrate)".
1709              
1710             -auto_pad If "left" or "right" keys are in use true
1711             then setting auto_pad to a true value
1712             will allow the panel to adjust its
1713             width in order to accomodate the
1714             length of the longest key.
1715              
1716             -empty_tracks What to do when a track is empty. suppress
1717             Options are to suppress the track
1718             completely ("suppress"), to show just
1719             the key in "between" mode ("key"),
1720             to draw a thin grey line ("line"),
1721             or to draw a dashed line ("dashed").
1722              
1723             -flip flip the drawing coordinates left false
1724             to right, so that lower coordinates
1725             are to the right. This can be
1726             useful for drawing (-) strand
1727             features.
1728              
1729             -all_callbacks Whether to invoke callbacks on false
1730             the automatic "track" and "group"
1731             glyphs.
1732              
1733             -grid Whether to draw a vertical grid in false
1734             the background. Pass a scalar true
1735             value to have a grid drawn at
1736             regular intervals (corresponding
1737             to the minor ticks of the arrow
1738             glyph). Pass an array reference
1739             to draw the grid at the specified
1740             positions.
1741              
1742             -gridcolor Color of the grid lightcyan
1743              
1744             -gridmajorcolor Color of grid major intervals cyan
1745              
1746             -extend_grid If true, extend the grid into the pad false
1747             top and pad_bottom regions
1748              
1749             -background An image or callback to use for the none
1750             background of the image. Will be
1751             invoked I<before> drawing the grid.
1752              
1753             -postgrid An image or callback to use for the none
1754             background of the image. Will be
1755             invoked I<after> drawing the grid.
1756              
1757             -truecolor Create a truecolor (24-bit) image. false
1758             Useful when working with the
1759             "image" glyph.
1760              
1761             -truetype Render text using scaleable vector false
1762             fonts rather than bitmap fonts.
1763              
1764             -image_class To create output in scalable vector
1765             graphics (SVG), optionally pass the image
1766             class parameter 'GD::SVG'. Defaults to
1767             using vanilla GD. See the corresponding
1768             image_class() method below for details.
1769              
1770             -link, -title, -target
1771             These options are used when creating imagemaps
1772             for display on the web. See L</"Creating Imagemaps">.
1773              
1774              
1775             Typically you will pass new() an object that implements the
1776             Bio::RangeI interface, providing a length() method, from which the
1777             panel will derive its scale.
1778              
1779             $panel = Bio::Graphics::Panel->new(-segment => $sequence,
1780             -width => 800);
1781              
1782             new() will return undef in case of an error.
1783              
1784             Note that if you use the "left" or "right" key styles, you are
1785             responsible for allocating sufficient -pad_left or -pad_right room for
1786             the labels to appear. The necessary width is the number of characters
1787             in the longest key times the font width (gdMediumBoldFont by default)
1788             plus 3 pixels of internal padding. The simplest way to calculate this
1789             is to iterate over the possible track labels, find the largest one,
1790             and then to compute its width using the formula:
1791              
1792             $width = gdMediumBoldFont->width * length($longest_key) +3;
1793              
1794             In order to obtain scalable vector graphics (SVG) output, you should
1795             pass new() the -image_class=E<gt>'GD::SVG' parameter. This will cause
1796             Bio::Graphics::Panel to load the optional GD::SVG module. See the gd()
1797             and svg() methods below for additional information.
1798              
1799             You can tile an image onto the panel either before or after it draws
1800             the grid. Simply provide the filename of the image in the -background
1801             or -postgrid options. The image file must be of type PNG, JPEG, XBM or
1802             GIF and have a filename ending in .png, .jpg, .jpeg, .xbm or .gif.
1803              
1804             You can also pass a code ref for the -background or -postgrid option,
1805             in which case the subroutine will be invoked at the appropriate time
1806             with the GD::Image object and the Panel object as its two arguments.
1807             You can then use the panel methods to map base pair coordinates into
1808             pixel coordinates and do some custom drawing. For example, this code
1809             fragment will draw a gray rectangle between bases 500 and 600 to
1810             indicate a "gap" in the sequence:
1811              
1812             my $panel = Bio::Graphics::Panel->new(-segment=>$segment,
1813             -grid=>1,
1814             -width=>600,
1815             -postgrid=> \&draw_gap);
1816             sub gap_it {
1817             my $gd = shift;
1818             my $panel = shift;
1819             my ($gap_start,$gap_end) = $panel->location2pixel(500,600);
1820             my $top = $panel->top;
1821             my $bottom = $panel->bottom;
1822             my $gray = $panel->translate_color('gray');
1823             $gd->filledRectangle($gap_start,$top,$gap_end,$bottom,$gray);
1824             }
1825              
1826             The B<-truetype> argument will activate rendering of labels using
1827             antialiased vector fonts. If it is a value of "1", then labels will be
1828             rendered using the default font (Verdana). Pass a font name to use
1829             this font as the default:
1830              
1831             -truetype => 'Times New Roman',
1832              
1833             Note that you can change the font on a track-by-track basis simply by
1834             using a truetype font name as add_track()'s -font argument.
1835              
1836             =back
1837              
1838             =head2 OBJECT METHODS
1839              
1840             =over 4
1841              
1842             =item $track = $panel-E<gt>add_track($glyph,$features,@options)
1843              
1844             The add_track() method adds a new track to the image.
1845              
1846             Tracks are horizontal bands which span the entire width of the panel.
1847             Each track contains a number of graphical elements called "glyphs",
1848             corresponding to a sequence feature.
1849              
1850             There are a large number of glyph types. By default, each track will
1851             be homogeneous on a single glyph type, but you can mix several glyph
1852             types on the same track by providing a code reference to the -glyph
1853             argument. Other options passed to add_track() control the color and
1854             size of the glyphs, whether they are allowed to overlap, and other
1855             formatting attributes. The height of a track is determined from its
1856             contents and cannot be directly influenced.
1857              
1858             The first two arguments are the glyph name and an array reference
1859             containing the list of features to display. The order of the
1860             arguments is irrelevant, allowing either of these idioms:
1861              
1862             $panel->add_track(arrow => \@features);
1863             $panel->add_track(\@features => 'arrow');
1864              
1865             The glyph name indicates how each feature is to be rendered. A
1866             variety of glyphs are available, and the number is growing. You may
1867             omit the glyph name entirely by providing a B<-glyph> argument among
1868             @options, as described below.
1869              
1870             Currently, the following glyphs are available:
1871              
1872             Name Description
1873             ---- -----------
1874              
1875             anchored_arrow
1876             a span with vertical bases |---------|. If one or
1877             the other end of the feature is off-screen, the base
1878             will be replaced by an arrow.
1879              
1880             arrow An arrow; can be unidirectional or bidirectional.
1881             It is also capable of displaying a scale with
1882             major and minor tickmarks, and can be oriented
1883             horizontally or vertically.
1884              
1885             box A filled rectangle, nondirectional. Subfeatures are ignored.
1886              
1887             cds Draws CDS features, using the phase information to
1888             show the reading frame usage. At high magnifications
1889             draws the protein translation.
1890              
1891             crossbox A box with a big "X" inside it.
1892              
1893             diamond A diamond, useful for point features like SNPs.
1894              
1895             dna At high magnification draws the DNA sequence. At
1896             low magnifications draws the GC content.
1897              
1898             dot A circle, useful for point features like SNPs, stop
1899             codons, or promoter elements.
1900              
1901             ellipse An oval.
1902              
1903             extending_arrow
1904             Similar to arrow, but a dotted line indicates when the
1905             feature extends beyond the end of the canvas.
1906              
1907             generic A filled rectangle, nondirectional. Subfeatures are shown
1908             as rectangles that are not connected together.
1909              
1910             graded_segments
1911             Similar to segments, but the intensity of the color
1912             is proportional to the score of the feature. This
1913             is used for showing the intensity of blast hits or
1914             other alignment features.
1915              
1916             group A group of related features connected by a dashed line.
1917             This is used internally by Panel.
1918              
1919             image A pixmap image that will be layered on top of the graphic.
1920              
1921             heterogeneous_segments
1922             Like segments, but you can use the source field of the feature
1923             to change the color of each segment.
1924              
1925             line A simple line.
1926              
1927             pinsertion A triangle designed to look like an insertion location
1928             (e.g. a transposon insertion).
1929              
1930             processed_transcript multi-purpose representation of a spliced mRNA, including
1931             positions of UTRs
1932              
1933             primers Two inward pointing arrows connected by a line.
1934             Used for STSs.
1935              
1936             redgreen_box A box that changes from green->yellow->red as the score
1937             of the feature increases from 0.0 to 1.0. Useful for
1938             representing microarray results.
1939              
1940             rndrect A round-cornered rectangle.
1941              
1942             segments A set of filled rectangles connected by solid lines.
1943             Used for interrupted features, such as gapped
1944             alignments.
1945              
1946             ruler_arrow An arrow with major and minor tick marks and interval
1947             labels.
1948              
1949             toomany Tries to show many features as a cloud. Not very successful.
1950              
1951             track A group of related features not connected by a line.
1952             This is used internally by Panel.
1953              
1954             transcript Similar to segments, but the connecting line is
1955             a "hat" shape, and the direction of transcription
1956             is indicated by a small arrow.
1957              
1958             transcript2 Similar to transcript, but the direction of
1959             transcription is indicated by a terminal exon
1960             in the shape of an arrow.
1961              
1962             translation 1, 2 and 3-frame translations. At low magnifications,
1963             can be configured to show start and stop codon locations.
1964             At high magnifications, shows the multi-frame protein
1965             translation.
1966              
1967             triangle A triangle whose width and orientation can be altered.
1968              
1969             xyplot Histograms and other graphs plotted against the genome.
1970              
1971             stackedplot A column plot showing multiple data series across multiple categories.
1972              
1973             ternary_plot Ternary (triangle) plots.
1974              
1975             whiskerplot Box and whisker plot for statistical data
1976              
1977             If the glyph name is omitted from add_track(), the "generic" glyph
1978             will be used by default. To get more information about a glyph, run
1979             perldoc on "Bio::Graphics::Glyph::glyphname", replacing "glyphname"
1980             with the name of the glyph you are interested in.
1981              
1982             The "box" glyph is optimized for single features with no
1983             subfeatures. If you are drawing such a feature, using "box" will be
1984             noticeably faster than "generic."
1985              
1986             The @options array is a list of name/value pairs that control the
1987             attributes of the track. Some options are interpretered directly by
1988             the track. Others are passed down to the individual glyphs (see
1989             L<"GLYPH OPTIONS">). The following options are track-specific:
1990              
1991             Option Description Default
1992             ------ ----------- -------
1993              
1994             -tkcolor Track color white
1995              
1996             -glyph Glyph class to use. "generic"
1997              
1998             -color_series Dynamically choose false
1999             bgcolor.
2000              
2001             -stylesheet Bio::Das::Stylesheet to none
2002             use to generate glyph
2003             classes and options.
2004              
2005             B<-tkcolor> controls the background color of the track as a whole.
2006              
2007             B<-glyph> controls the glyph type. If present, it supersedes the
2008             glyph name given in the first or second argument to add_track(). The
2009             value of B<-glyph> may be a constant string, a hash reference, or a
2010             code reference. In the case of a constant string, that string will be
2011             used as the class name for all generated glyphs. If a hash reference
2012             is passed, then the feature's primary_tag() will be used as the key to
2013             the hash, and the value, if any, used to generate the glyph type. If
2014             a code reference is passed, then this callback will be passed
2015             arguments consisting of the feature and the panel object. The
2016             callback is expected to examine the feature and return a glyph name as
2017             its single result.
2018              
2019             Example:
2020              
2021             $panel->add_track(\@exons,
2022             -glyph => sub { my ($feature,$panel) = @_;
2023             $feature->source_tag eq 'curated'
2024             ? 'ellipse' : 'box'; }
2025             );
2026              
2027             The B<-stylesheet> argument is used to pass a Bio::Das stylesheet
2028             object to the panel. This stylesheet will be called to determine both
2029             the glyph and the glyph options. If both a stylesheet and direct
2030             options are provided, the latter take precedence.
2031              
2032             The B<-color_series> argument causes the track to ignore the -bgcolor
2033             setting and instead to assign glyphs a series of contrasting
2034             colors. This is usually used in combination with -bump=>'overlap' in
2035             order to create overlapping features. A true value activates the color
2036             series. You may adjust the default color series using the
2037             B<-color_cycle> option, which is either a reference to an array of
2038             Bio::Graphics color values, or a space-delimited string of color
2039             names/value.
2040              
2041             If successful, add_track() returns an Bio::Graphics::Glyph object.
2042             You can use this object to add additional features or to control the
2043             appearance of the track with greater detail, or just ignore it.
2044             Tracks are added in order from the top of the image to the bottom. To
2045             add tracks to the top of the image, use unshift_track().
2046              
2047             B<Adding groups of features:> It is not uncommon to add a group of
2048             features which are logically connected, such as the 5' and 3' ends of
2049             EST reads. To group features into sets that remain on the same
2050             horizontal position and bump together, pass the sets as an anonymous
2051             array. For example:
2052              
2053             $panel->add_track(segments => [[$abc_5,$abc_3],
2054             [$xxx_5,$xxx_3],
2055             [$yyy_5,$yyy_3]]
2056             );
2057              
2058             Typical usage is:
2059              
2060             $panel->add_track( transcript => \@genes,
2061             -fillcolor => 'green',
2062             -fgcolor => 'black',
2063             -bump => +1,
2064             -height => 10,
2065             -label => 1);
2066              
2067             The track object is simply a specialized type of glyph. See
2068             L<Bio::Graphics::Glyph> for a description of the methods that it
2069             supports.
2070              
2071             =item $track = unshift_track($glyph,$features,@options)
2072              
2073             unshift_track() works like add_track(), except that the new track is
2074             added to the top of the image rather than the bottom.
2075              
2076             =item $track = $panel-E<gt>insert_track($position,$glyph,$features,@options)
2077              
2078             This works like add_track(), but the track is inserted into the
2079             indicated position. The track will be inserted B<before> the
2080             indicated position; thus specify a track of 0 to insert the new track
2081             at the beginning.
2082              
2083             =item $gd = $panel-E<gt>gd([$gd])
2084              
2085             The gd() method lays out the image and returns a GD::Image object
2086             containing it. You may then call the GD::Image object's png() or
2087             jpeg() methods to get the image data.
2088              
2089             Optionally, you may pass gd() a preexisting GD::Image object that you
2090             wish to draw on top of. If you do so, you should call the width() and
2091             height() methods first to ensure that the image has sufficient
2092             dimensions.
2093              
2094             If you passed new() the -image_class=E<gt>'GD::SVG' parameter, the gd() method
2095             returns a GD::SVG::Image object. This object overrides GD::Image
2096             methods in order to generate SVG output. It behaves exactly as
2097             described for GD::Image objects with one exception: it implements and
2098             svg() method instead of the png() or jpeg() methods. Currently there
2099             is no direct access to underlying SVG calls but this is subject to
2100             change in the future.
2101              
2102             =item $png = $panel-E<gt>png
2103              
2104             The png() method returns the image as a PNG-format drawing, without
2105             the intermediate step of returning a GD::Image object.
2106              
2107             =item $svg = $panel-E<gt>svg
2108              
2109             The svg() method returns the image in an XML-ified SVG format.
2110              
2111             =item $panel-E<gt>finished
2112              
2113             Bio::Graphics creates memory cycles. When you are finished with the
2114             panel, you should call its finished() method. Otherwise you will have
2115             memory leaks. This is only an issue if you're going to create several
2116             panels in a single program.
2117              
2118             =item $image_class = $panel-E<gt>image_class
2119              
2120             The image_class() method returns the current drawing package being
2121             used, currently one of GD or GD::SVG. This is primarily used
2122             internally to ensure that calls to GD's exported methods are called in
2123             an object-oriented manner to avoid compile time undefined string
2124             errors. This is usually not needed for external use.
2125              
2126             =item $image_package = $panel-E<gt>image_package
2127              
2128             This accessor method, like image_class() above is provided as a
2129             convenience. It returns the current image package in use, currently
2130             one of GD::Image or GD::SVG::Image. This is not normally used
2131             externally.
2132              
2133             =item $polygon_package = $panel-E<gt>polygon_package
2134              
2135             This accessor method, like image_package() above is provided as a
2136             convenience. It returns the current polygon package in use, currently
2137             one of GD::Polygon or GD::SVG::Polygon. This is not normally used
2138             externally except in the design of glyphs.
2139              
2140             =item $boxes = $panel-E<gt>boxes
2141              
2142             =item @boxes = $panel-E<gt>boxes
2143              
2144             The boxes() method returns a list of arrayrefs containing the
2145             coordinates of each glyph. The method is useful for constructing an
2146             image map. In a scalar context, boxes() returns an arrayref. In an
2147             list context, the method returns the list directly.
2148              
2149             Each member of the list is an arrayref of the following format:
2150              
2151             [ $feature, $x1, $y1, $x2, $y2, $track ]
2152              
2153             The first element is the feature object; either an
2154             Ace::Sequence::Feature, a Das::Segment::Feature, or another Bioperl
2155             Bio::SeqFeatureI object. The coordinates are the topleft and
2156             bottomright corners of the glyph, including any space allocated for
2157             labels. The track is the Bio::Graphics::Glyph object corresponding to
2158             the track that the feature is rendered inside.
2159              
2160             =item $boxes = $panel-E<gt>key_boxes
2161              
2162             =item @boxes = $panel-E<gt>key_boxes
2163              
2164             Returns the positions of the track keys as an arrayref or a list,
2165             depending on context. Each value in the list is an arrayref of format:
2166              
2167             [ $key_text, $x1, $y1, $x2, $y2, $track ]
2168              
2169             =item $position = $panel-E<gt>track_position($track)
2170              
2171             After calling gd() or boxes(), you can learn the resulting Y
2172             coordinate of a track by calling track_position() with the value
2173             returned by add_track() or unshift_track(). This will return undef if
2174             called before gd() or boxes() or with an invalid track.
2175              
2176             =item $rotate = $panel-E<gt>rotate([$new_value])
2177              
2178             Gets or sets the "rotate" flag. If rotate is set to true (default
2179             false), then calls to gd(), png(), gif(), boxes(), and image_and_map()
2180             will all return an image and/or imagemap that has been rotated to the
2181             right by 90 degrees. This is mostly useful for drawing karyotypes with
2182             the ideogram glyph, in order to rotate the chromosomes into the usual
2183             vertical position.
2184              
2185             =item @pixel_coords = $panel-E<gt>location2pixel(@feature_coords)
2186              
2187             Public routine to map feature coordinates (in base pairs) into pixel
2188             coordinates relative to the left-hand edge of the picture. If you
2189             define a -background callback, the callback may wish to invoke this
2190             routine in order to translate base coordinates into pixel coordinates.
2191              
2192             =item $left = $panel-E<gt>left
2193              
2194             =item $right = $panel-E<gt>right
2195              
2196             =item $top = $panel-E<gt>top
2197              
2198             =item $bottom = $panel-E<gt>bottom
2199              
2200             Return the pixel coordinates of the I<drawing area> of the panel, that
2201             is, exclusive of the padding.
2202              
2203             =back
2204              
2205             =head1 GLYPH OPTIONS
2206              
2207             Each glyph has its own specialized subset of options, but
2208             some are shared by all glyphs:
2209              
2210             Option Description Default
2211             ------ ----------- -------
2212              
2213             -key Description of track for undef
2214             display in the track label.
2215              
2216             -category The category of the track undef
2217             for display in the
2218             track label.
2219              
2220             -fgcolor Foreground color black
2221              
2222             -bgcolor Background color turquoise
2223              
2224             -linewidth Width of lines drawn by 1
2225             glyph
2226              
2227             -height Height of glyph 10
2228              
2229             -font Glyph font gdSmallFont
2230              
2231             -fontcolor Primary font color black
2232              
2233             -font2color Secondary font color turquoise
2234              
2235             -opacity Value from 0.0 (invisible) 1.0
2236             to 1.0 (opaque) which
2237             controls the translucency
2238             of overlapping features.
2239              
2240             -label Whether to draw a label false
2241              
2242             -description Whether to draw a false
2243             description
2244              
2245             -bump Bump direction 0
2246              
2247             -sort_order Specify layout sort order "default"
2248              
2249             -feature_limit
2250             Maximum number of features undef (unlimited)
2251             to display
2252              
2253             -bump_limit Maximum number of levels undef (unlimited)
2254             to bump
2255              
2256             -hbumppad Additional horizontal 0
2257             padding between bumped
2258             features
2259              
2260             -strand_arrow Whether to indicate undef (false)
2261             strandedness
2262              
2263             -stranded Synonym for -strand_arrow undef (false)
2264              
2265             -part_labels Whether to label individual undef (false)
2266             subparts.
2267              
2268             -part_label_merge Whether to merge undef (false)
2269             adjacent subparts when
2270             labeling.
2271              
2272             -connector Type of connector to none
2273             use to connect related
2274             features. Options are
2275             "solid," "hat", "dashed",
2276             "quill" and "none".
2277              
2278             -all_callbacks Whether to invoke undef
2279             callbacks for autogenerated
2280             "track" and "group" glyphs
2281              
2282             -subpart_callbacks Whether to invoke false
2283             callbacks for subparts of
2284             the glyph.
2285              
2286             -box_subparts Return boxes around feature 0
2287             subparts rather than around the
2288             feature itself.
2289              
2290             -link, -title, -target
2291             These options are used when creating imagemaps
2292             for display on the web. See L</"Creating Imagemaps">.
2293              
2294             -filter Select which features to
2295             display. Must be a CODE reference.
2296              
2297             B<Specifying colors:> Colors can be expressed in either of two ways:
2298             as symbolic names such as "cyan", as HTML-style #RRGGBB triples, and
2299             r,g,b comma-separated numbers. The symbolic names are the 140 colors
2300             defined in the Netscape/Internet Explorer color cube, and can be
2301             retrieved using the Bio::Graphics::Panel-E<gt>color_names() method.
2302              
2303             Transparent and semi-transparent colors can be specified using the
2304             following syntax:
2305              
2306             #RRGGBBAA - red, green, blue and alpha
2307             r,g,b,a - red, green, blue, alpha
2308             blue:alpha - symbolic name and alpha
2309             rgb(r,g,b) - CSS style rgb values
2310             rgba(r,g,b,a) - CSS style rgba values
2311              
2312             Alpha values can be specified as GD style integers ranging from 0
2313             (opaque) to 127 (transparent), or as CSS-style floating point numbers
2314             ranging from 0.0 (transparent) through 1.0 (opaque). As a special
2315             case, a completely transparent color can be specified using the color
2316             named "transparent". In the rgb() and rgba() forms, red, green, blue
2317             values can be specified as percentages, as in rgb(100%,0%,50%);
2318             otherwise, the values are integers from 0 to 255.
2319              
2320             In addition, the -fgcolor and -bgcolor options accept the special
2321             color names "featureScore" and "featureRGB". In the first case,
2322             Bio::Graphics will examine each feature in the track for a defined
2323             "score" tag (or the presence of a score() method) with a numeric value
2324             ranging from 0-1000. It will draw a grayscale color ranging from
2325             lightest (0) to darkest (1000). If the color is named "featureRGB",
2326             then Bio::Graphics will look for a tag named "RGB" and will use that
2327             as the color.
2328              
2329             B<Foreground color:> The -fgcolor option controls the foreground
2330             color, including the edges of boxes and the like.
2331              
2332             B<Background color:> The -bgcolor option controls the background used
2333             for filled boxes and other "solid" glyphs. The foreground color
2334             controls the color of lines and strings. The -tkcolor argument
2335             controls the background color of the entire track.
2336              
2337             B<Default opacity:>For truecolor images, you can apply a default opacity
2338             value to both foreground and background colors by supplying a B<-opacity>
2339             argument. This is specified as a CSS-style floating point number from
2340             0.0 to 1.0. If the color has an explicit alpha, then the default is
2341             ignored.
2342              
2343             B<Track color:> The -tkcolor option used to specify the background of
2344             the entire track.
2345              
2346             B<Font:> The -font option controls which font will be used. If the
2347             Panel was created without passing a true value to -truecolor, then
2348             only GD bitmapped fonts are available to you. These include
2349             'gdTinyFont', 'gdSmallFont', 'gdLargeFont', 'gdMediumBoldFont', and
2350             'gdGiantFont'. If the Panel was creaed using a truevalue for
2351             -truecolor, then you can pass the name of any truetype font installed
2352             on the server system. Any of these formats will work:
2353              
2354             -font => 'Times New Roman', # Times font, let the system pick size
2355             -font => 'Times New Roman-12' # Times font, 12 points
2356             -font => 'Times New Roman-12:Italic' # Times font, 12 points italic
2357             -font => 'Times New Roman-12:Bold' # Times font, 12 points bold
2358              
2359             B<Font color:> The -fontcolor option controls the color of primary
2360             text, such as labels
2361              
2362             B<Secondary Font color:> The -font2color option controls the color of
2363             secondary text, such as descriptions.
2364              
2365             B<Labels:> The -label argument controls whether or not the ID of the
2366             feature should be printed next to the feature. It is accepted by all
2367             glyphs. By default, the label is printed just above the glyph and
2368             left aligned with it.
2369              
2370             -label can be a constant string or a code reference. Values can be
2371             any of:
2372              
2373             -label value Description
2374             ------------ -----------
2375              
2376             0 Don't draw a label
2377             1 Calculate a label based on primary tag of sequence
2378             "a string" Use "a string" as the label
2379             code ref Invoke the code reference to compute the label
2380              
2381             A known bug with this naming scheme is that you can't label a feature
2382             with the string "1". To work around this, use "1 " (note the terminal
2383             space).
2384              
2385             B<Descriptions:> The -description argument controls whether or not a
2386             brief description of the feature should be printed next to it. By
2387             default, the description is printed just below the glyph and
2388             left-aligned with it. A value of 0 will suppress the description. A
2389             value of 1 will "magically" look for tags of type "note" or
2390             "description" and draw them if found, otherwise the source tag, if
2391             any, will be displayed. A code reference will be invoked to calculate
2392             the description on the fly. Anything else will be treated as a string
2393             and used verbatim.
2394              
2395             B<Connectors:> A glyph can contain subglyphs, recursively. The top
2396             level glyph is the track, which contains one or more groups, which
2397             contain features, which contain subfeatures, and so forth. By
2398             default, the "group" glyph draws dotted lines between each of its
2399             subglyphs, the "segment" glyph draws a solid line between each of its
2400             subglyphs, and the "transcript" and "transcript2" glyphs draw
2401             hat-shaped lines between their subglyphs. All other glyphs do not
2402             connect their components. You can override this behavior by providing
2403             a -connector option, to explicitly set the type of connector. Valid
2404             options are:
2405              
2406              
2407             "hat" an upward-angling conector
2408             "solid" a straight horizontal connector
2409             "quill" a decorated line with small arrows indicating strandedness
2410             (like the UCSC Genome Browser uses)
2411             "dashed" a horizontal dashed line.
2412              
2413             The B<-connector_color> option controls the color of the connector, if
2414             any.
2415              
2416             B<Collision control:> The B<-bump> argument controls what happens when
2417             glyphs collide. By default, they will simply overlap (value 0). A
2418             -bump value of +1 will cause overlapping glyphs to bump downwards
2419             until there is room for them. A -bump value of -1 will cause
2420             overlapping glyphs to bump upwards. You may also provide a -bump
2421             value of +2 or -2 to activate a very simple type of collision control
2422             in which each feature occupies its own line. This is useful for
2423             showing dense, nearly-full length features such as similarity hits. A
2424             bump of 3 or the string "fast" will turn on a faster
2425             collision-detection algorithm that only works properly with the
2426             default "left" sort order.
2427              
2428             Finally, a bump value of "overlap" will cause features to overlap each
2429             other and to made partially translucent (the translucency can be
2430             controlled with the -opacity setting). Features that are on opposite
2431             strands will bump, but those on the same strand will not.
2432              
2433             The bump argument can also be a code reference; see below.
2434              
2435             For convenience and backwards compatibility, if you specify a -bump
2436             of 1 and use the default sort order, the faster algorithm will be
2437             used.
2438              
2439             If you would like to see more horizontal whitespace between features
2440             that occupy the same line, you can specify it with the B<-hbumppad>
2441             option. Positive values increase the amount of whitespace between
2442             features. Negative values decrease the whitespace.
2443              
2444             B<Keys:> The -key argument declares that the track is to be shown in a
2445             key appended to the bottom of the image. The key contains a picture
2446             of a glyph and a label describing what the glyph means. The label is
2447             specified in the argument to -key.
2448              
2449             B<box_subparts:> Ordinarily, when you invoke the boxes() methods to
2450             retrieve the rectangles surrounding the glyphs (which you need to do
2451             to create clickable imagemaps, for example), the rectangles will
2452             surround the top level features. If you wish for the rectangles to
2453             surround subpieces of the glyph, such as the exons in a transcript,
2454             set box_subparts to a true numeric value. The value you specify will
2455             control the number of levels of subfeatures that the boxes will
2456             descend into. For example, if using the "gene" glyph, set
2457             -box_subparts to 2 to create boxes for the whole gene (level 0), the
2458             mRNAs (level 1) and the exons (level 2).
2459              
2460             B<part_labels:> If set to true, each subpart of a multipart feature
2461             will be labeled with a number starting with 1 at the 5'-most
2462             part. This is useful for counting exons. You can pass a callback to
2463             this argument; the part number and the total number of parts will be
2464             arguments three and four. For example, to label the exons as "exon 1",
2465             "exon 2" and so on:
2466              
2467             -part_labels => sub {
2468             my ($feature,undef,$partno) = @_;
2469             return 'exon '.($partno+1);
2470             }
2471              
2472             The B<-label> argument must also be true.
2473              
2474             B<part_labels_merge:> If true, changes the behavior of -part_labels so
2475             that features that abut each other without a gap are treated as a
2476             single feature. Useful if you want to count the UTR and CDS segments
2477             of an exon as a single unit, and the default for transcript glyphs.
2478              
2479             B<strand_arrow:> If set to true, some glyphs will indicate their
2480             strandedness, usually by drawing an arrow. For this to work, the
2481             Bio::SeqFeature must have a strand of +1 or -1. The glyph will ignore
2482             this directive if the underlying feature has a strand of zero or
2483             undef.
2484              
2485             B<sort_order>: By default, features are drawn with a layout based only on the
2486             position of the feature, assuring a maximal "packing" of the glyphs
2487             when bumped. In some cases, however, it makes sense to display the
2488             glyphs sorted by score or some other comparison, e.g. such that more
2489             "important" features are nearer the top of the display, stacked above
2490             less important features. The -sort_order option allows a few
2491             different built-in values for changing the default sort order (which
2492             is by "left" position): "low_score" (or "high_score") will cause
2493             features to be sorted from lowest to highest score (or vice versa).
2494             "left" (or "default") and "right" values will cause features to be
2495             sorted by their position in the sequence. "longest" (or "shortest")
2496             will cause the longest (or shortest) features to be sorted first, and
2497             "strand" will cause the features to be sorted by strand: "+1"
2498             (forward) then "0" (unknown, or NA) then "-1" (reverse).
2499              
2500             In all cases, the "left" position will be used to break any ties. To
2501             break ties using another field, options may be strung together using a
2502             "|" character; e.g. "strand|low_score|right" would cause the features
2503             to be sorted first by strand, then score (lowest to highest), then by
2504             "right" position in the sequence.
2505              
2506             Finally, a subroutine coderef with a $$ prototype can be provided. It
2507             will receive two B<glyph> as arguments and should return -1, 0 or 1
2508             (see Perl's sort() function for more information). For example, to
2509             sort a set of database search hits by bits (stored in the features'
2510             "score" fields), scaled by the log of the alignment length (with
2511             "start" position breaking any ties):
2512              
2513             sort_order = sub ($$) {
2514             my ($glyph1,$glyph2) = @_;
2515             my $a = $glyph1->feature;
2516             my $b = $glyph2->feature;
2517             ( $b->score/log($b->length)
2518             <=>
2519             $a->score/log($a->length) )
2520             ||
2521             ( $a->start <=> $b->start )
2522             }
2523              
2524             It is important to remember to use the $$ prototype as shown in the
2525             example. Otherwise Bio::Graphics will quit with an exception. The
2526             arguments are subclasses of Bio::Graphics::Glyph, not the features
2527             themselves. While glyphs implement some, but not all, of the feature
2528             methods, to be safe call the two glyphs' feature() methods in order to
2529             convert them into the actual features.
2530              
2531             The '-always_sort' option, if true, will sort features even if bumping
2532             is turned off. This is useful if you would like overlapping features
2533             to stack in a particular order. Features towards the end of the list
2534             will overlay those towards the beginning of the sort order.
2535              
2536             B<-feature_limit>: When this option is set to a non-zero value, calls
2537             to a track's add_feature() method will maintain a count of features
2538             added to a track. Once the feature count exceeds the value set in
2539             -feature_limit, additional features will displace existing ones in a
2540             way that effects a uniform sampling of the total feature set. This is
2541             useful to protect against excessively large tracks. The total number
2542             of features added can be retrieved by calling the track's
2543             feature_count() method.
2544              
2545             B<-bump_limit>: When bumping is chosen, colliding features will
2546             ordinarily move upward or downward without limit. When many features
2547             collide, this can lead to excessively high images. You can limit the
2548             number of levels that features will bump by providing a numeric
2549             B<bump_limit> option. After the limit is hit, features will pile up on
2550             top of each other, usually as a band at the bottom of the track.
2551              
2552             The B<-filter> option, which must be a CODE reference, will be invoked
2553             once for each feature prior to rendering it. The coderef will receive
2554             the feature as its single option and should return true if the feature
2555             is to be shown and false otherwise.
2556              
2557             =head2 Options and Callbacks
2558              
2559             Instead of providing a constant value to an option, you may subsitute
2560             a code reference. This code reference will be called every time the
2561             panel needs to configure a glyph. The callback will be called with
2562             three arguments like this:
2563              
2564             sub callback {
2565             my ($feature,$option_name,$part_no,$total_parts,$glyph) = @_;
2566             # do something which results in $option_value being set
2567             return $option_value;
2568             }
2569              
2570             The five arguments are C<$feature>, a reference to the IO::SeqFeatureI
2571             object, C<$option_name>, the name of the option to configure,
2572             C<$part_no>, an integer index indicating which subpart of the feature
2573             is being drawn, C<$total_parts>, an integer indicating the total
2574             number of subfeatures in the feature, and finally C<$glyph>, the Glyph
2575             object itself. The latter fields are useful in the case of treating
2576             the first or last subfeature differently, such as using a different
2577             color for the terminal exon of a gene. Usually you will only need to
2578             examine the first argument. This example shows a callback examining
2579             the score() attribute of a feature (possibly a BLAST hit) and return
2580             the color "red" for high-scoring features, and "green" for low-scoring
2581             features:
2582              
2583             sub callback {
2584             my $feature = shift;
2585             if ($feature->score > 90) {
2586             return 'red';
2587             else {
2588             return 'green';
2589             }
2590             }
2591              
2592             The callback should return a string indicating the desired value of
2593             the option. To tell the panel to use the default value for this
2594             option, return the string "*default*".
2595              
2596             The callback for -grid is slightly different because at the time this
2597             option is needed there is no glyph defined. In this case, the callback
2598             will get two arguments: the feature and the panel object:
2599              
2600             -glyph => sub {
2601             my ($feature,$panel) = @_;
2602             return 'gene' if $panel->length < 10_000;
2603             return 'box';
2604             }
2605              
2606             When you install a callback for a feature that contains subparts, the
2607             callback will be invoked first for the top-level feature, and then for
2608             each of its subparts (recursively). You should make sure to examine
2609             the feature's type to determine whether the option is appropriate.
2610              
2611             Also be aware that some options are only called for subfeatures. For
2612             example, when using multi-segmented features, the "bgcolor" and
2613             "fgcolor" options apply to the subfeatures and not to the whole
2614             feature; therefore the corresponding callbacks will only be invoked
2615             for the subfeatures and not for the top-level feature. To get
2616             information that applies to the top-level feature, use the glyph's
2617             parent_feature() method. This returns:
2618              
2619             * the parent if called with no arguments or with an argument of (1)
2620             * the parent's parent if called with an argument of (2)
2621             * the parent's parent's parent if called with an argument of (3)
2622             * etc.
2623              
2624             The general way to take advantage of this feature is:
2625              
2626             sub callback {
2627             my ($feature,$option_name,$part_no,$total_parts,$glyph) = @_;
2628             my $parent = $glyph->parent_feature();
2629              
2630             # do something which results in $option_value being set
2631             return $option_value;
2632             }
2633              
2634             or, more concisely:
2635              
2636             sub callback {
2637             my $feature = shift; # first argument
2638             my $glyph = pop; # last argument
2639             my $parent = $glyph->parent_feature();
2640              
2641             # do something which results in $option_value being set
2642             return $option_value;
2643             }
2644              
2645             Some glyphs deliberately disable recursion into subparts. The
2646             "track", "group", "transcript", "transcript2" and "segments" glyphs
2647             selectively disable the -bump, -label and -description options. This
2648             is to avoid, for example, a label being attached to each exon in a
2649             transcript, or the various segments of a gapped alignment bumping each
2650             other. You can override this behavior and force your callback to be
2651             invoked by providing add_track() with a true B<-all_callbacks>
2652             argument. In this case, you must be prepared to handle configuring
2653             options for the "group" and "track" glyphs.
2654              
2655             In particular, this means that in order to control the -bump option
2656             with a callback, you should specify -all_callbacks=E<gt>1, and turn on
2657             bumping when the callback is in the track or group glyphs.
2658              
2659             The -subpart_callbacks options is similar, except that when this is
2660             set to true callbacks are invoked for the main glyph and its
2661             subparts. This option only affects the -label and -description
2662             options.
2663              
2664             =head2 ACCESSORS
2665              
2666             The following accessor methods provide access to various attributes of
2667             the panel object. Called with no arguments, they each return the
2668             current value of the attribute. Called with a single argument, they
2669             set the attribute and return its previous value.
2670              
2671             Note that in most cases you must change attributes prior to invoking
2672             gd(), png() or boxes(). These three methods all invoke an internal
2673             layout() method which places the tracks and the glyphs within them,
2674             and then caches the result.
2675              
2676             Accessor Name Description
2677             ------------- -----------
2678              
2679             width() Get/set width of panel
2680             spacing() Get/set spacing between tracks
2681             key_spacing() Get/set spacing between keys
2682             length() Get/set length of segment (bp)
2683             flip() Get/set coordinate flipping
2684             pad_top() Get/set top padding
2685             pad_left() Get/set left padding
2686             pad_bottom() Get/set bottom padding
2687             pad_right() Get/set right padding
2688             start() Get the start of the sequence (bp; read only)
2689             end() Get the end of the sequence (bp; read only)
2690             left() Get the left side of the drawing area (pixels; read only)
2691             right() Get the right side of the drawing area (pixels; read only)
2692              
2693             =head2 COLOR METHODS
2694              
2695             The following methods are used internally, but may be useful for those
2696             implementing new glyph types.
2697              
2698             =over 4
2699              
2700             =item @names = Bio::Graphics::Panel-E<gt>color_names
2701              
2702             Return the symbolic names of the colors recognized by the panel
2703             object. In a scalar context, returns an array reference.
2704              
2705             =item ($red,$green,$blue) = Bio::Graphics::Panel-E<gt>color_name_to_rgb($color)
2706              
2707             Given a symbolic color name, returns the red, green, blue components
2708             of the color. In a scalar context, returns an array reference to the
2709             rgb triplet. Returns undef for an invalid color name.
2710              
2711             =item @rgb = $panel-E<gt>rgb($index)
2712              
2713             Given a GD color index (between 0 and 140), returns the RGB triplet
2714             corresponding to this index. This method is only useful within a
2715             glyph's draw() routine, after the panel has allocated a GD::Image and
2716             is populating it.
2717              
2718             =item $index = $panel-E<gt>translate_color($color)
2719              
2720             Given a color, returns the GD::Image index. The color may be
2721             symbolic, such as "turquoise", or a #RRGGBB triple, as in #F0E0A8.
2722             This method is only useful within a glyph's draw() routine, after the
2723             panel has allocated a GD::Image and is populating it.
2724              
2725             =item $panel-E<gt>set_pen($width,$color)
2726              
2727             Changes the width and color of the GD drawing pen to the values
2728             indicated. This is called automatically by the GlyphFactory fgcolor()
2729             method. It returns the GD value gdBrushed, which should be used for
2730             drawing.
2731              
2732             =back
2733              
2734             =head2 Creating Imagemaps
2735              
2736             You may wish to use Bio::Graphics to create clickable imagemaps for
2737             display on the web. The main method for achieving this is
2738             image_and_map(). Under special circumstances you may instead wish to
2739             call either or both of create_web_image() and create_web_map().
2740              
2741             Here is a synopsis of how to use image_and_map() in a CGI script,
2742             using CGI.pm calls to provide the HTML scaffolding:
2743              
2744             print h2('My Genome');
2745              
2746             my ($url,$map,$mapname) =
2747             $panel->image_and_map(-root => '/var/www/html',
2748             -url => '/tmpimages',
2749             -link => 'http://www.google.com/search?q=$name');
2750              
2751             print img({-src=>$url,-usemap=>"#$mapname"});
2752              
2753             print $map;
2754              
2755             We call image_and_map() with various arguments (described below) to
2756             generate a three element list consisting of the URL at which the image
2757             can be accessed, an HTML fragment containing the clickable imagemap
2758             data, and the name of the map. We print out an E<lt>imageE<gt> tag
2759             that uses the URL of the map as its src attribute and the name of the
2760             map as the value of its usemap attribute. It is important to note
2761             that we must put a "#" in front of the name of the map in order to
2762             indicate that the map can be found in the same document as the
2763             E<lt>imageE<gt> tag. Lastly, we print out the map itself.
2764              
2765             =over 4
2766              
2767             =item ($url,$map,$mapname) = $panel-E<gt>image_and_map(@options)
2768              
2769             Create the image in a web-accessible directory and return its URL, its
2770             clickable imagemap, and the name of the imagemap. The following
2771             options are recognized:
2772              
2773             Option Description
2774             ------ -----------
2775              
2776             -url The URL to store the image at.
2777              
2778              
2779             -root The directory path that should be appended to the
2780             start of -url in order to obtain a physical
2781             directory path.
2782             -link A string pattern or coderef that will be used to
2783             generate the outgoing hypertext links for the imagemap.
2784              
2785             -title A string pattern or coderef that will be used to
2786             generate the "title" tags of each element in the imagemap
2787             (these appear as popup hint boxes in certain browsers).
2788              
2789             -target A string pattern or coderef that will be used to
2790             generate the window target for each element. This can
2791             be used to pop up a new window when the user clicks on
2792             an element.
2793              
2794             -mapname The name to use for the E<lt>mapE<gt> tag. If not provided,
2795             a unique one will be autogenerated for you.
2796              
2797             This method returns a three element list consisting of the URL at
2798             which the image has been written to, the imagemap HTML, and the name
2799             of the map. Usually you will incorporate this information into an
2800             HTML document like so:
2801              
2802             my ($url,$map,$mapname) =
2803             $panel->image_and_map(-link=>'http://www.google.com/search?q=$name');
2804             print qq(<img src="$url" usemap="#$mapname">),"\n";
2805             print $map,"\n";
2806              
2807             =item $url = $panel-E<gt>create_web_image($url,$root)
2808              
2809             Create the image, write it into the directory indicated by
2810             concatenating $root and $url (i.e. "$root/$url"), and return $url.
2811              
2812             =item $map = $panel-E<gt>create_web_map('mapname',$linkrule,$titlerule,$targetrule)
2813              
2814             Create a clickable imagemap named "mapname" using the indicated rules
2815             to generate the hypertext links, the element titles, and the window
2816             targets for the graphical elements. Return the HTML for the map,
2817             including the enclosing E<lt>mapE<gt> tag itself.
2818              
2819             =back
2820              
2821             To use this method effectively, you will need a web server and an
2822             image directory in the document tree that is writable by the web
2823             server user. For example, if your web server's document root is
2824             located at /var/www/html, you might want to create a directory named
2825             "tmpimages" for this purpose:
2826              
2827             mkdir /var/www/html/tmpimages
2828             chmod 1777 /var/www/html/tmpimages
2829              
2830             The 1777 privilege will allow anyone to create files and
2831             subdirectories in this directory, but only the owner of the file will
2832             be able to delete it.
2833              
2834             When you call image_and_map(), you must provide it with two vital
2835             pieces of information: the URL of the image directory and the physical
2836             location of the web server's document tree. In our example, you would
2837             call:
2838              
2839             $panel->image_and_map(-root => '/var/www/html',-url=>'/tmpimages');
2840              
2841             If you are working with virtual hosts, you might wish to provide the
2842             hostname:portnumber part of the URL. This will work just as well:
2843              
2844             $panel->image_and_map(-root => '/var/www/html',
2845             -url => 'http://myhost.com:8080/tmpimages');
2846              
2847             If you do not provide the -root argument, the method will try to
2848             figure it out from the DOCUMENT_ROOT environment variable. If you do
2849             not provide the -url argument, the method will assume "/tmp".
2850              
2851             During execution, the image_and_map() method will generate a unique
2852             name for the image using the Digest::MD5 module. You can get this
2853             module on CPAN and it B<must> be installed in order to use
2854             image_and_map(). The imagename will be a long hexadecimal string such
2855             as "e7457643f12d413f20843d4030c197c6.png". Its URL will be
2856             /tmpimages/e7457643f12d413f20843d4030c197c6.png, and its physical path
2857             will be /var/www/html/tmpimages/e7457643f12d413f20843d4030c197c6.png
2858              
2859             In addition to providing directory information, you must also tell
2860             image_and_map() how to create outgoing links for each graphical
2861             feature, and, optionally, how to create the "hover title" (the popup
2862             yellow box displayed by most modern browsers), and the name of the
2863             window or frame to link to when the user clicks on it.
2864              
2865             There are three ways to specify the link destination:
2866              
2867             =over 4
2868              
2869             =item 1.
2870              
2871             By configuring one or more tracks with a -link argument.
2872              
2873             =item 2.
2874              
2875             By configuring the panel with a -link argument.
2876              
2877             =item 3.
2878              
2879             By passing a -link argument in the call to image_and_map().
2880              
2881             =back
2882              
2883             The -link argument can be either a string or a coderef. If you pass a
2884             string, it will be interpreted as a URL pattern containing runtime
2885             variables. These variables begin with a dollar sign ($), and are
2886             replaced at run time with the information relating to the selected
2887             annotation. Recognized variables include:
2888              
2889             $name The feature's name (display name)
2890             $id The feature's id (eg, PK from a database)
2891             $class The feature's class (group class)
2892             $method The feature's method (same as primary tag)
2893             $source The feature's source
2894             $ref The name of the sequence segment (chromosome, contig)
2895             on which this feature is located
2896             $description The feature's description (notes)
2897             $start The start position of this feature, relative to $ref
2898             $end The end position of this feature, relative to $ref
2899             $length Length of this feature
2900             $segstart The left end of $ref displayed in the detailed view
2901             $segend The right end of $ref displayed in the detailed view
2902              
2903             For example, to link each feature to a Google search on the feature's
2904             description, use the argument:
2905              
2906             -link => 'http://www.google.com/search?q=$description'
2907              
2908             Be sure to use single quotes around the pattern, or Perl will attempt
2909             to perform variable interpretation before image_and_map() has a chance
2910             to work on it.
2911              
2912             You may also pass a code reference to -link, in which case the code
2913             will be called every time a URL needs to be generated for the
2914             imagemap. The subroutine will be called with two arguments, the
2915             feature and the Bio::Graphics::Panel object, and it should return the
2916             URL to link to, or an empty string if a link is not desired. Here is a
2917             simple example:
2918              
2919             -link => sub {
2920             my ($feature,$panel) = @_;
2921             my $type = $feature->primary_tag;
2922             my $name = $feature->display_name;
2923             if ($primary_tag eq 'clone') {
2924             return "http://www.google.com/search?q=$name";
2925             } else {
2926             return "http://www.yahoo.com/search?p=$name";
2927             }
2928              
2929             The -link argument cascades. image_and_map() will first look for a
2930             -link option in the track configuration, and if that's not found, it
2931             will look in the Panel configuration (created during
2932             Bio::Graphics::Panel-E<gt>new). If no -link configuration option is found
2933             in either location, then image_and_map() will use the value of -link
2934             passed in its argument list, if any.
2935              
2936             The -title and -target options behave in a similar manner to -link.
2937             -title is used to assign each feature "title" and "alt" attributes.
2938             The "title" attribute is used by many browsers to create a popup hints
2939             box when the mouse hovers over the feature's glyph for a preset length
2940             of time, while the "alt" attribute is used to create navigable menu
2941             items for the visually impaired. As with -link, you can set the title
2942             by passing either a substitution pattern or a code ref, and the -title
2943             option can be set in the track, the panel, or the method call itself
2944             in that order of priority.
2945              
2946             If not provided, image_and_map() will autogenerate its own title in
2947             the form "E<lt>methodE<gt> E<lt>display_nameE<gt> E<lt>seqidE<gt>:start..end".
2948              
2949             The -target option can be used to specify the window or frame that
2950             clicked features will link to. By default, when the user clicks on a
2951             feature, the loaded URL will replace the current page. You can modify
2952             this by providing -target with the name of a preexisting or new window
2953             name in order to create effects like popup windows, multiple frames,
2954             popunders and the like. The value of -target follows the same rules
2955             as -title and -link, including variable substitution and the use of
2956             code refs.
2957              
2958             NOTE: Each time you call image_and_map() it will generate a new image
2959             file. Images that are identical to an earlier one will reuse the same
2960             name, but those that are different, even by one pixel, will result in
2961             the generation of a new image. If you have limited disk space, you
2962             might wish to check the images directory periodically and remove those
2963             that have not been accessed recently. The following cron script will
2964             remove image files that haven't been accessed in more than 20 days.
2965              
2966             30 2 * * * find /var/www/html/tmpimages -type f -atime +20 -exec rm {} \;
2967              
2968             =head1 BUGS
2969              
2970             Please report them.
2971              
2972             =head1 SEE ALSO
2973              
2974             L<Bio::Graphics::Glyph>,
2975             L<Bio::Graphics::Glyph::arrow>,
2976             L<Bio::Graphics::Glyph::cds>,
2977             L<Bio::Graphics::Glyph::crossbox>,
2978             L<Bio::Graphics::Glyph::diamond>,
2979             L<Bio::Graphics::Glyph::dna>,
2980             L<Bio::Graphics::Glyph::dot>,
2981             L<Bio::Graphics::Glyph::ellipse>,
2982             L<Bio::Graphics::Glyph::extending_arrow>,
2983             L<Bio::Graphics::Glyph::generic>,
2984             L<Bio::Graphics::Glyph::graded_segments>,
2985             L<Bio::Graphics::Glyph::heterogeneous_segments>,
2986             L<Bio::Graphics::Glyph::line>,
2987             L<Bio::Graphics::Glyph::pinsertion>,
2988             L<Bio::Graphics::Glyph::primers>,
2989             L<Bio::Graphics::Glyph::rndrect>,
2990             L<Bio::Graphics::Glyph::segments>,
2991             L<Bio::Graphics::Glyph::redgreen_box>,
2992             L<Bio::Graphics::Glyph::ruler_arrow>,
2993             L<Bio::Graphics::Glyph::toomany>,
2994             L<Bio::Graphics::Glyph::transcript>,
2995             L<Bio::Graphics::Glyph::transcript2>,
2996             L<Bio::Graphics::Glyph::translation>,
2997             L<Bio::Graphics::Glyph::triangle>,
2998             L<Bio::Graphics::Glyph::xyplot>,
2999             L<Bio::Graphics::Glyph::whiskerplot>,
3000             L<Bio::SeqI>,
3001             L<Bio::SeqFeatureI>,
3002             L<Bio::Das>,
3003             L<GD>
3004             L<GD::SVG>
3005             L<glyph_help.pl>
3006              
3007             =head1 AUTHOR
3008              
3009             Lincoln Stein E<lt>lstein@cshl.orgE<gt>
3010              
3011             Copyright (c) 2001 Cold Spring Harbor Laboratory
3012              
3013             This library is free software; you can redistribute it and/or modify
3014             it under the same terms as Perl itself. See DISCLAIMER.txt for
3015             disclaimers of warranty.
3016              
3017             =cut
3018