1package Bio::Graphics::Panel; 2 3use strict; 4use Bio::Graphics::Glyph::Factory; 5use Bio::Graphics::Feature; 6use Bio::Graphics::GDWrapper; 7 8# KEYLABELFONT must be treated as string until image_class is established 9use constant KEYLABELFONT => 'gdMediumBoldFont'; 10use constant KEYSPACING => 5; # extra space between key columns 11use constant KEYPADTOP => 5; # extra padding before the key starts 12use constant KEYCOLOR => 'wheat'; 13use constant KEYSTYLE => 'bottom'; 14use constant KEYALIGN => 'left'; 15use constant GRIDCOLOR => 'lightcyan'; 16use constant GRIDMAJORCOLOR => 'lightgrey'; 17use constant MISSING_TRACK_COLOR =>'gray'; 18use constant EXTRA_RIGHT_PADDING => 30; 19 20use base qw(Bio::Root::Root); 21our $GlyphScratch; 22 23my %COLORS; # translation table for symbolic color names to RGB triple 24my $IMAGEMAP = 'bgmap00001'; 25read_colors(); 26 27sub 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 31sub 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 123sub rotate { 124 my $self = shift; 125 my $d = $self->{rotate}; 126 $self->{rotate} = shift if @_; 127 $d; 128} 129 130sub pad_left { 131 my $self = shift; 132 my $g = $self->{pad_left}; 133 $self->{pad_left} = shift if @_; 134 $g; 135} 136sub pad_right { 137 my $self = shift; 138 my $g = $self->{pad_right}; 139 $self->{pad_right} = shift if @_; 140 $g; 141} 142sub pad_top { 143 my $self = shift; 144 my $g = $self->{pad_top}; 145 $self->{pad_top} = shift if @_; 146 $g; 147} 148sub pad_bottom { 149 my $self = shift; 150 my $g = $self->{pad_bottom}; 151 $self->{pad_bottom} = shift if @_; 152 $g; 153} 154sub extend_grid { 155 my $self = shift; 156 my $g = $self->{extend_grid}; 157 $self->{extend_grid} = shift if @_; 158 $g; 159} 160sub flip { 161 my $self = shift; 162 my $g = $self->{flip}; 163 $self->{flip} = shift if @_; 164 $g; 165} 166sub 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 178sub 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 185sub key_style { 186 my $self = shift; 187 my $g = $self->{key_style}; 188 $self->{key_style} = shift if @_; 189 $g; 190} 191 192sub 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 201sub 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 209sub 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 230sub 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 247sub scale { 248 my $self = shift; 249 $self->{scale} ||= $self->width/($self->length); 250} 251 252sub start { shift->{offset}+1} 253sub end { $_[0]->start + $_[0]->{length}-1} 254 255sub offset { shift->{offset} } 256sub width { 257 my $self = shift; 258 my $d = $self->{width}; 259 $self->{width} = shift if @_; 260 $d; 261} 262 263sub left { 264 my $self = shift; 265 $self->pad_left; 266} 267sub right { 268 my $self = shift; 269 $self->pad_left + $self->width; # - $self->pad_right; 270} 271sub top { 272 shift->pad_top; 273} 274sub bottom { 275 my $self = shift; 276 $self->height - $self->pad_bottom; 277} 278 279sub spacing { 280 my $self = shift; 281 my $d = $self->{spacing}; 282 $self->{spacing} = shift if @_; 283 $d; 284} 285 286sub key_spacing { 287 my $self = shift; 288 my $d = $self->{key_spacing}; 289 $self->{key_spacing} = shift if @_; 290 $d; 291} 292 293sub 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 304sub gridcolor {shift->{gridcolor}} 305 306sub gridmajorcolor {shift->{gridmajorcolor}} 307 308sub all_callbacks { shift->{all_callbacks} } 309 310sub add_track { 311 my $self = shift; 312 $self->_do_add_track(scalar(@{$self->{tracks}}),@_); 313} 314 315sub unshift_track { 316 my $self = shift; 317 $self->_do_add_track(0,@_); 318} 319 320sub 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 330sub _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 389sub _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 420sub _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 451sub extra_right_padding { EXTRA_RIGHT_PADDING } 452 453sub 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 487sub 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 497sub 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 623sub 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 643sub 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 654sub 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 667sub startGroup { 668 my $self = shift; 669 my $gd = shift; 670 $gd->startGroup if $gd->can('startGroup'); 671} 672 673sub 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 682sub image_class { return shift->{image_class}; } 683sub image_package { return shift->{image_package}; } 684sub polygon_package { return shift->{polygon_package}; } 685 686sub 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 732sub 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 741sub 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 757sub 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 775sub 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 789sub 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 884sub 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 891sub key_boxes { 892 my $ref = shift->{key_boxes}; 893 return wantarray ? @$ref : $ref; 894} 895 896sub 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 903sub track2key { 904 my $self = shift; 905 my $track = shift; 906 return $track->make_key_name(); 907} 908 909sub 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 927sub 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) 958sub 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 989sub 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 1020sub rgb { 1021 my $self = shift; 1022 my $idx = shift; 1023 my $gd = $self->{gd} or return; 1024 return $gd->rgb($idx); 1025} 1026 1027sub transparent_color { 1028 my $self = shift; 1029 my ($opacity,@colors) = @_; 1030 return $self->_translate_color($opacity,@colors); 1031} 1032 1033sub translate_color { 1034 my $self = shift; 1035 my @colors = @_; 1036 return $self->_translate_color(1.0,@colors); 1037} 1038 1039sub _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) 1097sub 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 1109sub 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 1125sub bgcolor { 1126 my $self = shift; 1127 return unless $self->{bgcolor}; 1128 return $self->translate_color($self->{bgcolor}); 1129} 1130 1131sub 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 1146sub png { 1147 my $gd = shift->gd; 1148 $gd->png; 1149} 1150 1151sub 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. 1161sub 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 1182sub 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 1217sub 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 1254sub 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 1262sub 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 1270sub 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 1282sub 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 1291sub color_names { 1292 my $class = shift; 1293 $class->read_colors unless %COLORS; 1294 return wantarray ? keys %COLORS : [keys %COLORS]; 1295} 1296 1297sub glyph_scratch { 1298 my $self = shift; 1299 my $d = $GlyphScratch; 1300 $GlyphScratch = shift if @_; 1301 $d; 1302} 1303 1304sub finished { 1305 my $self = shift; 1306 for my $track (@{$self->{tracks} || []}) { 1307 $track->finished(); 1308 } 1309 delete $self->{tracks}; 1310} 1311 13121; 1313 1314__DATA__ 1315white FF FF FF 1316black 00 00 00 1317aliceblue F0 F8 FF 1318antiquewhite FA EB D7 1319aqua 00 FF FF 1320aquamarine 7F FF D4 1321azure F0 FF FF 1322beige F5 F5 DC 1323bisque FF E4 C4 1324blanchedalmond FF EB CD 1325blue 00 00 FF 1326blueviolet 8A 2B E2 1327brown A5 2A 2A 1328burlywood DE B8 87 1329cadetblue 5F 9E A0 1330chartreuse 7F FF 00 1331chocolate D2 69 1E 1332coral FF 7F 50 1333cornflowerblue 64 95 ED 1334cornsilk FF F8 DC 1335crimson DC 14 3C 1336cyan 00 FF FF 1337darkblue 00 00 8B 1338darkcyan 00 8B 8B 1339darkgoldenrod B8 86 0B 1340darkgray A9 A9 A9 1341darkgreen 00 64 00 1342darkkhaki BD B7 6B 1343darkmagenta 8B 00 8B 1344darkolivegreen 55 6B 2F 1345darkorange FF 8C 00 1346darkorchid 99 32 CC 1347darkred 8B 00 00 1348darksalmon E9 96 7A 1349darkseagreen 8F BC 8F 1350darkslateblue 48 3D 8B 1351darkslategray 2F 4F 4F 1352darkturquoise 00 CE D1 1353darkviolet 94 00 D3 1354deeppink FF 14 100 1355deepskyblue 00 BF FF 1356dimgray 69 69 69 1357dodgerblue 1E 90 FF 1358firebrick B2 22 22 1359floralwhite FF FA F0 1360forestgreen 22 8B 22 1361fuchsia FF 00 FF 1362gainsboro DC DC DC 1363ghostwhite F8 F8 FF 1364gold FF D7 00 1365goldenrod DA A5 20 1366gray 80 80 80 1367grey 80 80 80 1368green 00 80 00 1369greenyellow AD FF 2F 1370honeydew F0 FF F0 1371hotpink FF 69 B4 1372indianred CD 5C 5C 1373indigo 4B 00 82 1374ivory FF FF F0 1375khaki F0 E6 8C 1376lavender E6 E6 FA 1377lavenderblush FF F0 F5 1378lawngreen 7C FC 00 1379lemonchiffon FF FA CD 1380lightblue AD D8 E6 1381lightcoral F0 80 80 1382lightcyan E0 FF FF 1383lightgoldenrodyellow FA FA D2 1384lightgreen 90 EE 90 1385lightgrey D3 D3 D3 1386lightpink FF B6 C1 1387lightsalmon FF A0 7A 1388lightseagreen 20 B2 AA 1389lightskyblue 87 CE FA 1390lightslategray 77 88 99 1391lightsteelblue B0 C4 DE 1392lightyellow FF FF E0 1393lime 00 FF 00 1394limegreen 32 CD 32 1395linen FA F0 E6 1396magenta FF 00 FF 1397maroon 80 00 00 1398mediumaquamarine 66 CD AA 1399mediumblue 00 00 CD 1400mediumorchid BA 55 D3 1401mediumpurple 100 70 DB 1402mediumseagreen 3C B3 71 1403mediumslateblue 7B 68 EE 1404mediumspringgreen 00 FA 9A 1405mediumturquoise 48 D1 CC 1406mediumvioletred C7 15 85 1407midnightblue 19 19 70 1408mintcream F5 FF FA 1409mistyrose FF E4 E1 1410moccasin FF E4 B5 1411navajowhite FF DE AD 1412navy 00 00 80 1413oldlace FD F5 E6 1414olive 80 80 00 1415olivedrab 6B 8E 23 1416orange FF A5 00 1417orangered FF 45 00 1418orchid DA 70 D6 1419palegoldenrod EE E8 AA 1420palegreen 98 FB 98 1421paleturquoise AF EE EE 1422palevioletred DB 70 100 1423papayawhip FF EF D5 1424peachpuff FF DA B9 1425peru CD 85 3F 1426pink FF C0 CB 1427plum DD A0 DD 1428powderblue B0 E0 E6 1429purple 80 00 80 1430red FF 00 00 1431rosybrown BC 8F 8F 1432royalblue 41 69 E1 1433saddlebrown 8B 45 13 1434salmon FA 80 72 1435sandybrown F4 A4 60 1436seagreen 2E 8B 57 1437seashell FF F5 EE 1438sienna A0 52 2D 1439silver C0 C0 C0 1440skyblue 87 CE EB 1441slateblue 6A 5A CD 1442slategray 70 80 90 1443snow FF FA FA 1444springgreen 00 FF 7F 1445steelblue 46 82 B4 1446tan D2 B4 8C 1447teal 00 80 80 1448thistle D8 BF D8 1449tomato FF 63 47 1450turquoise 40 E0 D0 1451violet EE 82 EE 1452wheat F5 DE B3 1453whitesmoke F5 F5 F5 1454yellow FF FF 00 1455yellowgreen 9A CD 32 1456gradient1 00 ff 00 1457gradient2 0a ff 00 1458gradient3 14 ff 00 1459gradient4 1e ff 00 1460gradient5 28 ff 00 1461gradient6 32 ff 00 1462gradient7 3d ff 00 1463gradient8 47 ff 00 1464gradient9 51 ff 00 1465gradient10 5b ff 00 1466gradient11 65 ff 00 1467gradient12 70 ff 00 1468gradient13 7a ff 00 1469gradient14 84 ff 00 1470gradient15 8e ff 00 1471gradient16 99 ff 00 1472gradient17 a3 ff 00 1473gradient18 ad ff 00 1474gradient19 b7 ff 00 1475gradient20 c1 ff 00 1476gradient21 cc ff 00 1477gradient22 d6 ff 00 1478gradient23 e0 ff 00 1479gradient24 ea ff 00 1480gradient25 f4 ff 00 1481gradient26 ff ff 00 1482gradient27 ff f4 00 1483gradient28 ff ea 00 1484gradient29 ff e0 00 1485gradient30 ff d6 00 1486gradient31 ff cc 00 1487gradient32 ff c1 00 1488gradient33 ff b7 00 1489gradient34 ff ad 00 1490gradient35 ff a3 00 1491gradient36 ff 99 00 1492gradient37 ff 8e 00 1493gradient38 ff 84 00 1494gradient39 ff 7a 00 1495gradient40 ff 70 00 1496gradient41 ff 65 00 1497gradient42 ff 5b 00 1498gradient43 ff 51 00 1499gradient44 ff 47 00 1500gradient45 ff 3d 00 1501gradient46 ff 32 00 1502gradient47 ff 28 00 1503gradient48 ff 1e 00 1504gradient49 ff 14 00 1505gradient50 ff 0a 00 1506__END__ 1507 1508=head1 NAME 1509 1510Bio::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 1579The Bio::Graphics::Panel class provides drawing and formatting 1580services for any object that implements the Bio::SeqFeatureI 1581interface, including Ace::Sequence::Feature and Das::Segment::Feature 1582objects. It can be used to draw sequence annotations, physical 1583(contig) maps, or any other type of map in which a set of discrete 1584ranges need to be laid out on the number line. 1585 1586The module supports a drawing style in which each type of feature 1587occupies a discrete "track" that spans the width of the display. Each 1588track will have its own distinctive "glyph", a configurable graphical 1589representation of the feature. 1590 1591The module also supports a more flexible style in which several 1592different feature types and their associated glyphs can occupy the 1593same track. The choice of glyph is under run-time control. 1594 1595Semantic zooming (for instance, changing the type of glyph depending 1596on the density of features) is supported by a callback system for 1597configuration variables. The module has built-in support for Bio::Das 1598stylesheets, and stylesheet-driven configuration can be intermixed 1599with semantic zooming, if desired. 1600 1601You can add a key to the generated image using either of two key 1602styles. One style places the key captions at the top of each track. 1603The other style generates a graphical key at the bottom of the image. 1604 1605Note that this module depends on GD. The optional SVG output depends 1606on GD::SVG and SVG. 1607 1608The installed script glyph_help.pl provides quick help on glyphs and 1609their options. 1610 1611=head1 METHODS 1612 1613This section describes the class and object methods for 1614Bio::Graphics::Panel. 1615 1616Typically you will begin by creating a new Bio::Graphics::Panel 1617object, passing it the desired width of the image to generate and an 1618origin and length describing the coordinate range to display. The 1619Bio::Graphics::Panel-E<gt>new() method has many configuration variables 1620that allow you to control the appearance of the image. 1621 1622You will then call add_track() one or more times to add sets of 1623related features to the picture. add_track() places a new horizontal 1624track on the image, and is likewise highly configurable. When you 1625have added all the features you desire, you may call png() to convert 1626the image into a PNG-format image, or boxes() to return coordinate 1627information that can be used to create an imagemap. 1628 1629=head2 CONSTRUCTORS 1630 1631new() is the constructor for Bio::Graphics::Panel: 1632 1633=over 4 1634 1635=item $panel = Bio::Graphics::Panel-E<gt>new(@options) 1636 1637The new() method creates a new panel object. The options are 1638a 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 1775Typically you will pass new() an object that implements the 1776Bio::RangeI interface, providing a length() method, from which the 1777panel will derive its scale. 1778 1779 $panel = Bio::Graphics::Panel->new(-segment => $sequence, 1780 -width => 800); 1781 1782new() will return undef in case of an error. 1783 1784Note that if you use the "left" or "right" key styles, you are 1785responsible for allocating sufficient -pad_left or -pad_right room for 1786the labels to appear. The necessary width is the number of characters 1787in the longest key times the font width (gdMediumBoldFont by default) 1788plus 3 pixels of internal padding. The simplest way to calculate this 1789is to iterate over the possible track labels, find the largest one, 1790and then to compute its width using the formula: 1791 1792 $width = gdMediumBoldFont->width * length($longest_key) +3; 1793 1794In order to obtain scalable vector graphics (SVG) output, you should 1795pass new() the -image_class=E<gt>'GD::SVG' parameter. This will cause 1796Bio::Graphics::Panel to load the optional GD::SVG module. See the gd() 1797and svg() methods below for additional information. 1798 1799You can tile an image onto the panel either before or after it draws 1800the grid. Simply provide the filename of the image in the -background 1801or -postgrid options. The image file must be of type PNG, JPEG, XBM or 1802GIF and have a filename ending in .png, .jpg, .jpeg, .xbm or .gif. 1803 1804You can also pass a code ref for the -background or -postgrid option, 1805in which case the subroutine will be invoked at the appropriate time 1806with the GD::Image object and the Panel object as its two arguments. 1807You can then use the panel methods to map base pair coordinates into 1808pixel coordinates and do some custom drawing. For example, this code 1809fragment will draw a gray rectangle between bases 500 and 600 to 1810indicate 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 1826The B<-truetype> argument will activate rendering of labels using 1827antialiased vector fonts. If it is a value of "1", then labels will be 1828rendered using the default font (Verdana). Pass a font name to use 1829this font as the default: 1830 1831 -truetype => 'Times New Roman', 1832 1833Note that you can change the font on a track-by-track basis simply by 1834using 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 1844The add_track() method adds a new track to the image. 1845 1846Tracks are horizontal bands which span the entire width of the panel. 1847Each track contains a number of graphical elements called "glyphs", 1848corresponding to a sequence feature. 1849 1850There are a large number of glyph types. By default, each track will 1851be homogeneous on a single glyph type, but you can mix several glyph 1852types on the same track by providing a code reference to the -glyph 1853argument. Other options passed to add_track() control the color and 1854size of the glyphs, whether they are allowed to overlap, and other 1855formatting attributes. The height of a track is determined from its 1856contents and cannot be directly influenced. 1857 1858The first two arguments are the glyph name and an array reference 1859containing the list of features to display. The order of the 1860arguments is irrelevant, allowing either of these idioms: 1861 1862 $panel->add_track(arrow => \@features); 1863 $panel->add_track(\@features => 'arrow'); 1864 1865The glyph name indicates how each feature is to be rendered. A 1866variety of glyphs are available, and the number is growing. You may 1867omit the glyph name entirely by providing a B<-glyph> argument among 1868@options, as described below. 1869 1870Currently, 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 1977If the glyph name is omitted from add_track(), the "generic" glyph 1978will be used by default. To get more information about a glyph, run 1979perldoc on "Bio::Graphics::Glyph::glyphname", replacing "glyphname" 1980with the name of the glyph you are interested in. 1981 1982The "box" glyph is optimized for single features with no 1983subfeatures. If you are drawing such a feature, using "box" will be 1984noticeably faster than "generic." 1985 1986The @options array is a list of name/value pairs that control the 1987attributes of the track. Some options are interpretered directly by 1988the track. Others are passed down to the individual glyphs (see 1989L<"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 2005B<-tkcolor> controls the background color of the track as a whole. 2006 2007B<-glyph> controls the glyph type. If present, it supersedes the 2008glyph name given in the first or second argument to add_track(). The 2009value of B<-glyph> may be a constant string, a hash reference, or a 2010code reference. In the case of a constant string, that string will be 2011used as the class name for all generated glyphs. If a hash reference 2012is passed, then the feature's primary_tag() will be used as the key to 2013the hash, and the value, if any, used to generate the glyph type. If 2014a code reference is passed, then this callback will be passed 2015arguments consisting of the feature and the panel object. The 2016callback is expected to examine the feature and return a glyph name as 2017its single result. 2018 2019Example: 2020 2021 $panel->add_track(\@exons, 2022 -glyph => sub { my ($feature,$panel) = @_; 2023 $feature->source_tag eq 'curated' 2024 ? 'ellipse' : 'box'; } 2025 ); 2026 2027The B<-stylesheet> argument is used to pass a Bio::Das stylesheet 2028object to the panel. This stylesheet will be called to determine both 2029the glyph and the glyph options. If both a stylesheet and direct 2030options are provided, the latter take precedence. 2031 2032The B<-color_series> argument causes the track to ignore the -bgcolor 2033setting and instead to assign glyphs a series of contrasting 2034colors. This is usually used in combination with -bump=>'overlap' in 2035order to create overlapping features. A true value activates the color 2036series. You may adjust the default color series using the 2037B<-color_cycle> option, which is either a reference to an array of 2038Bio::Graphics color values, or a space-delimited string of color 2039names/value. 2040 2041If successful, add_track() returns an Bio::Graphics::Glyph object. 2042You can use this object to add additional features or to control the 2043appearance of the track with greater detail, or just ignore it. 2044Tracks are added in order from the top of the image to the bottom. To 2045add tracks to the top of the image, use unshift_track(). 2046 2047B<Adding groups of features:> It is not uncommon to add a group of 2048features which are logically connected, such as the 5' and 3' ends of 2049EST reads. To group features into sets that remain on the same 2050horizontal position and bump together, pass the sets as an anonymous 2051array. For example: 2052 2053 $panel->add_track(segments => [[$abc_5,$abc_3], 2054 [$xxx_5,$xxx_3], 2055 [$yyy_5,$yyy_3]] 2056 ); 2057 2058Typical 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 2067The track object is simply a specialized type of glyph. See 2068L<Bio::Graphics::Glyph> for a description of the methods that it 2069supports. 2070 2071=item $track = unshift_track($glyph,$features,@options) 2072 2073unshift_track() works like add_track(), except that the new track is 2074added to the top of the image rather than the bottom. 2075 2076=item $track = $panel-E<gt>insert_track($position,$glyph,$features,@options) 2077 2078This works like add_track(), but the track is inserted into the 2079indicated position. The track will be inserted B<before> the 2080indicated position; thus specify a track of 0 to insert the new track 2081at the beginning. 2082 2083=item $gd = $panel-E<gt>gd([$gd]) 2084 2085The gd() method lays out the image and returns a GD::Image object 2086containing it. You may then call the GD::Image object's png() or 2087jpeg() methods to get the image data. 2088 2089Optionally, you may pass gd() a preexisting GD::Image object that you 2090wish to draw on top of. If you do so, you should call the width() and 2091height() methods first to ensure that the image has sufficient 2092dimensions. 2093 2094If you passed new() the -image_class=E<gt>'GD::SVG' parameter, the gd() method 2095returns a GD::SVG::Image object. This object overrides GD::Image 2096methods in order to generate SVG output. It behaves exactly as 2097described for GD::Image objects with one exception: it implements and 2098svg() method instead of the png() or jpeg() methods. Currently there 2099is no direct access to underlying SVG calls but this is subject to 2100change in the future. 2101 2102=item $png = $panel-E<gt>png 2103 2104The png() method returns the image as a PNG-format drawing, without 2105the intermediate step of returning a GD::Image object. 2106 2107=item $svg = $panel-E<gt>svg 2108 2109The svg() method returns the image in an XML-ified SVG format. 2110 2111=item $panel-E<gt>finished 2112 2113Bio::Graphics creates memory cycles. When you are finished with the 2114panel, you should call its finished() method. Otherwise you will have 2115memory leaks. This is only an issue if you're going to create several 2116panels in a single program. 2117 2118=item $image_class = $panel-E<gt>image_class 2119 2120The image_class() method returns the current drawing package being 2121used, currently one of GD or GD::SVG. This is primarily used 2122internally to ensure that calls to GD's exported methods are called in 2123an object-oriented manner to avoid compile time undefined string 2124errors. This is usually not needed for external use. 2125 2126=item $image_package = $panel-E<gt>image_package 2127 2128This accessor method, like image_class() above is provided as a 2129convenience. It returns the current image package in use, currently 2130one of GD::Image or GD::SVG::Image. This is not normally used 2131externally. 2132 2133=item $polygon_package = $panel-E<gt>polygon_package 2134 2135This accessor method, like image_package() above is provided as a 2136convenience. It returns the current polygon package in use, currently 2137one of GD::Polygon or GD::SVG::Polygon. This is not normally used 2138externally except in the design of glyphs. 2139 2140=item $boxes = $panel-E<gt>boxes 2141 2142=item @boxes = $panel-E<gt>boxes 2143 2144The boxes() method returns a list of arrayrefs containing the 2145coordinates of each glyph. The method is useful for constructing an 2146image map. In a scalar context, boxes() returns an arrayref. In an 2147list context, the method returns the list directly. 2148 2149Each member of the list is an arrayref of the following format: 2150 2151 [ $feature, $x1, $y1, $x2, $y2, $track ] 2152 2153The first element is the feature object; either an 2154Ace::Sequence::Feature, a Das::Segment::Feature, or another Bioperl 2155Bio::SeqFeatureI object. The coordinates are the topleft and 2156bottomright corners of the glyph, including any space allocated for 2157labels. The track is the Bio::Graphics::Glyph object corresponding to 2158the 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 2164Returns the positions of the track keys as an arrayref or a list, 2165depending 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 2171After calling gd() or boxes(), you can learn the resulting Y 2172coordinate of a track by calling track_position() with the value 2173returned by add_track() or unshift_track(). This will return undef if 2174called before gd() or boxes() or with an invalid track. 2175 2176=item $rotate = $panel-E<gt>rotate([$new_value]) 2177 2178Gets or sets the "rotate" flag. If rotate is set to true (default 2179false), then calls to gd(), png(), gif(), boxes(), and image_and_map() 2180will all return an image and/or imagemap that has been rotated to the 2181right by 90 degrees. This is mostly useful for drawing karyotypes with 2182the ideogram glyph, in order to rotate the chromosomes into the usual 2183vertical position. 2184 2185=item @pixel_coords = $panel-E<gt>location2pixel(@feature_coords) 2186 2187Public routine to map feature coordinates (in base pairs) into pixel 2188coordinates relative to the left-hand edge of the picture. If you 2189define a -background callback, the callback may wish to invoke this 2190routine 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 2200Return the pixel coordinates of the I<drawing area> of the panel, that 2201is, exclusive of the padding. 2202 2203=back 2204 2205=head1 GLYPH OPTIONS 2206 2207Each glyph has its own specialized subset of options, but 2208some 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 2297B<Specifying colors:> Colors can be expressed in either of two ways: 2298as symbolic names such as "cyan", as HTML-style #RRGGBB triples, and 2299r,g,b comma-separated numbers. The symbolic names are the 140 colors 2300defined in the Netscape/Internet Explorer color cube, and can be 2301retrieved using the Bio::Graphics::Panel-E<gt>color_names() method. 2302 2303Transparent and semi-transparent colors can be specified using the 2304following 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 2312Alpha values can be specified as GD style integers ranging from 0 2313(opaque) to 127 (transparent), or as CSS-style floating point numbers 2314ranging from 0.0 (transparent) through 1.0 (opaque). As a special 2315case, a completely transparent color can be specified using the color 2316named "transparent". In the rgb() and rgba() forms, red, green, blue 2317values can be specified as percentages, as in rgb(100%,0%,50%); 2318otherwise, the values are integers from 0 to 255. 2319 2320In addition, the -fgcolor and -bgcolor options accept the special 2321color names "featureScore" and "featureRGB". In the first case, 2322Bio::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 2324ranging from 0-1000. It will draw a grayscale color ranging from 2325lightest (0) to darkest (1000). If the color is named "featureRGB", 2326then Bio::Graphics will look for a tag named "RGB" and will use that 2327as the color. 2328 2329B<Foreground color:> The -fgcolor option controls the foreground 2330color, including the edges of boxes and the like. 2331 2332B<Background color:> The -bgcolor option controls the background used 2333for filled boxes and other "solid" glyphs. The foreground color 2334controls the color of lines and strings. The -tkcolor argument 2335controls the background color of the entire track. 2336 2337B<Default opacity:>For truecolor images, you can apply a default opacity 2338value to both foreground and background colors by supplying a B<-opacity> 2339argument. This is specified as a CSS-style floating point number from 23400.0 to 1.0. If the color has an explicit alpha, then the default is 2341ignored. 2342 2343B<Track color:> The -tkcolor option used to specify the background of 2344the entire track. 2345 2346B<Font:> The -font option controls which font will be used. If the 2347Panel was created without passing a true value to -truecolor, then 2348only 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 2352on 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 2359B<Font color:> The -fontcolor option controls the color of primary 2360text, such as labels 2361 2362B<Secondary Font color:> The -font2color option controls the color of 2363secondary text, such as descriptions. 2364 2365B<Labels:> The -label argument controls whether or not the ID of the 2366feature should be printed next to the feature. It is accepted by all 2367glyphs. By default, the label is printed just above the glyph and 2368left aligned with it. 2369 2370-label can be a constant string or a code reference. Values can be 2371any 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 2381A known bug with this naming scheme is that you can't label a feature 2382with the string "1". To work around this, use "1 " (note the terminal 2383space). 2384 2385B<Descriptions:> The -description argument controls whether or not a 2386brief description of the feature should be printed next to it. By 2387default, the description is printed just below the glyph and 2388left-aligned with it. A value of 0 will suppress the description. A 2389value of 1 will "magically" look for tags of type "note" or 2390"description" and draw them if found, otherwise the source tag, if 2391any, will be displayed. A code reference will be invoked to calculate 2392the description on the fly. Anything else will be treated as a string 2393and used verbatim. 2394 2395B<Connectors:> A glyph can contain subglyphs, recursively. The top 2396level glyph is the track, which contains one or more groups, which 2397contain features, which contain subfeatures, and so forth. By 2398default, the "group" glyph draws dotted lines between each of its 2399subglyphs, the "segment" glyph draws a solid line between each of its 2400subglyphs, and the "transcript" and "transcript2" glyphs draw 2401hat-shaped lines between their subglyphs. All other glyphs do not 2402connect their components. You can override this behavior by providing 2403a -connector option, to explicitly set the type of connector. Valid 2404options 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 2413The B<-connector_color> option controls the color of the connector, if 2414any. 2415 2416B<Collision control:> The B<-bump> argument controls what happens when 2417glyphs collide. By default, they will simply overlap (value 0). A 2418-bump value of +1 will cause overlapping glyphs to bump downwards 2419until there is room for them. A -bump value of -1 will cause 2420overlapping glyphs to bump upwards. You may also provide a -bump 2421value of +2 or -2 to activate a very simple type of collision control 2422in which each feature occupies its own line. This is useful for 2423showing dense, nearly-full length features such as similarity hits. A 2424bump of 3 or the string "fast" will turn on a faster 2425collision-detection algorithm that only works properly with the 2426default "left" sort order. 2427 2428Finally, a bump value of "overlap" will cause features to overlap each 2429other and to made partially translucent (the translucency can be 2430controlled with the -opacity setting). Features that are on opposite 2431strands will bump, but those on the same strand will not. 2432 2433The bump argument can also be a code reference; see below. 2434 2435For convenience and backwards compatibility, if you specify a -bump 2436of 1 and use the default sort order, the faster algorithm will be 2437used. 2438 2439If you would like to see more horizontal whitespace between features 2440that occupy the same line, you can specify it with the B<-hbumppad> 2441option. Positive values increase the amount of whitespace between 2442features. Negative values decrease the whitespace. 2443 2444B<Keys:> The -key argument declares that the track is to be shown in a 2445key appended to the bottom of the image. The key contains a picture 2446of a glyph and a label describing what the glyph means. The label is 2447specified in the argument to -key. 2448 2449B<box_subparts:> Ordinarily, when you invoke the boxes() methods to 2450retrieve the rectangles surrounding the glyphs (which you need to do 2451to create clickable imagemaps, for example), the rectangles will 2452surround the top level features. If you wish for the rectangles to 2453surround subpieces of the glyph, such as the exons in a transcript, 2454set box_subparts to a true numeric value. The value you specify will 2455control the number of levels of subfeatures that the boxes will 2456descend into. For example, if using the "gene" glyph, set 2457-box_subparts to 2 to create boxes for the whole gene (level 0), the 2458mRNAs (level 1) and the exons (level 2). 2459 2460B<part_labels:> If set to true, each subpart of a multipart feature 2461will be labeled with a number starting with 1 at the 5'-most 2462part. This is useful for counting exons. You can pass a callback to 2463this argument; the part number and the total number of parts will be 2464arguments 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 2472The B<-label> argument must also be true. 2473 2474B<part_labels_merge:> If true, changes the behavior of -part_labels so 2475that features that abut each other without a gap are treated as a 2476single feature. Useful if you want to count the UTR and CDS segments 2477of an exon as a single unit, and the default for transcript glyphs. 2478 2479B<strand_arrow:> If set to true, some glyphs will indicate their 2480strandedness, usually by drawing an arrow. For this to work, the 2481Bio::SeqFeature must have a strand of +1 or -1. The glyph will ignore 2482this directive if the underlying feature has a strand of zero or 2483undef. 2484 2485B<sort_order>: By default, features are drawn with a layout based only on the 2486position of the feature, assuring a maximal "packing" of the glyphs 2487when bumped. In some cases, however, it makes sense to display the 2488glyphs sorted by score or some other comparison, e.g. such that more 2489"important" features are nearer the top of the display, stacked above 2490less important features. The -sort_order option allows a few 2491different built-in values for changing the default sort order (which 2492is by "left" position): "low_score" (or "high_score") will cause 2493features to be sorted from lowest to highest score (or vice versa). 2494"left" (or "default") and "right" values will cause features to be 2495sorted by their position in the sequence. "longest" (or "shortest") 2496will 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 2500In all cases, the "left" position will be used to break any ties. To 2501break ties using another field, options may be strung together using a 2502"|" character; e.g. "strand|low_score|right" would cause the features 2503to be sorted first by strand, then score (lowest to highest), then by 2504"right" position in the sequence. 2505 2506Finally, a subroutine coderef with a $$ prototype can be provided. It 2507will 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 2509sort 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 2524It is important to remember to use the $$ prototype as shown in the 2525example. Otherwise Bio::Graphics will quit with an exception. The 2526arguments are subclasses of Bio::Graphics::Glyph, not the features 2527themselves. While glyphs implement some, but not all, of the feature 2528methods, to be safe call the two glyphs' feature() methods in order to 2529convert them into the actual features. 2530 2531The '-always_sort' option, if true, will sort features even if bumping 2532is turned off. This is useful if you would like overlapping features 2533to stack in a particular order. Features towards the end of the list 2534will overlay those towards the beginning of the sort order. 2535 2536B<-feature_limit>: When this option is set to a non-zero value, calls 2537to a track's add_feature() method will maintain a count of features 2538added to a track. Once the feature count exceeds the value set in 2539-feature_limit, additional features will displace existing ones in a 2540way that effects a uniform sampling of the total feature set. This is 2541useful to protect against excessively large tracks. The total number 2542of features added can be retrieved by calling the track's 2543feature_count() method. 2544 2545B<-bump_limit>: When bumping is chosen, colliding features will 2546ordinarily move upward or downward without limit. When many features 2547collide, this can lead to excessively high images. You can limit the 2548number of levels that features will bump by providing a numeric 2549B<bump_limit> option. After the limit is hit, features will pile up on 2550top of each other, usually as a band at the bottom of the track. 2551 2552The B<-filter> option, which must be a CODE reference, will be invoked 2553once for each feature prior to rendering it. The coderef will receive 2554the feature as its single option and should return true if the feature 2555is to be shown and false otherwise. 2556 2557=head2 Options and Callbacks 2558 2559Instead of providing a constant value to an option, you may subsitute 2560a code reference. This code reference will be called every time the 2561panel needs to configure a glyph. The callback will be called with 2562three 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 2570The five arguments are C<$feature>, a reference to the IO::SeqFeatureI 2571object, C<$option_name>, the name of the option to configure, 2572C<$part_no>, an integer index indicating which subpart of the feature 2573is being drawn, C<$total_parts>, an integer indicating the total 2574number of subfeatures in the feature, and finally C<$glyph>, the Glyph 2575object itself. The latter fields are useful in the case of treating 2576the first or last subfeature differently, such as using a different 2577color for the terminal exon of a gene. Usually you will only need to 2578examine the first argument. This example shows a callback examining 2579the score() attribute of a feature (possibly a BLAST hit) and return 2580the color "red" for high-scoring features, and "green" for low-scoring 2581features: 2582 2583 sub callback { 2584 my $feature = shift; 2585 if ($feature->score > 90) { 2586 return 'red'; 2587 else { 2588 return 'green'; 2589 } 2590 } 2591 2592The callback should return a string indicating the desired value of 2593the option. To tell the panel to use the default value for this 2594option, return the string "*default*". 2595 2596The callback for -grid is slightly different because at the time this 2597option is needed there is no glyph defined. In this case, the callback 2598will 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 2606When you install a callback for a feature that contains subparts, the 2607callback will be invoked first for the top-level feature, and then for 2608each of its subparts (recursively). You should make sure to examine 2609the feature's type to determine whether the option is appropriate. 2610 2611Also be aware that some options are only called for subfeatures. For 2612example, when using multi-segmented features, the "bgcolor" and 2613"fgcolor" options apply to the subfeatures and not to the whole 2614feature; therefore the corresponding callbacks will only be invoked 2615for the subfeatures and not for the top-level feature. To get 2616information that applies to the top-level feature, use the glyph's 2617parent_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 2624The 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 2634or, 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 2645Some glyphs deliberately disable recursion into subparts. The 2646"track", "group", "transcript", "transcript2" and "segments" glyphs 2647selectively disable the -bump, -label and -description options. This 2648is to avoid, for example, a label being attached to each exon in a 2649transcript, or the various segments of a gapped alignment bumping each 2650other. You can override this behavior and force your callback to be 2651invoked by providing add_track() with a true B<-all_callbacks> 2652argument. In this case, you must be prepared to handle configuring 2653options for the "group" and "track" glyphs. 2654 2655In particular, this means that in order to control the -bump option 2656with a callback, you should specify -all_callbacks=E<gt>1, and turn on 2657bumping when the callback is in the track or group glyphs. 2658 2659The -subpart_callbacks options is similar, except that when this is 2660set to true callbacks are invoked for the main glyph and its 2661subparts. This option only affects the -label and -description 2662options. 2663 2664=head2 ACCESSORS 2665 2666The following accessor methods provide access to various attributes of 2667the panel object. Called with no arguments, they each return the 2668current value of the attribute. Called with a single argument, they 2669set the attribute and return its previous value. 2670 2671Note that in most cases you must change attributes prior to invoking 2672gd(), png() or boxes(). These three methods all invoke an internal 2673layout() method which places the tracks and the glyphs within them, 2674and 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 2695The following methods are used internally, but may be useful for those 2696implementing new glyph types. 2697 2698=over 4 2699 2700=item @names = Bio::Graphics::Panel-E<gt>color_names 2701 2702Return the symbolic names of the colors recognized by the panel 2703object. 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 2707Given a symbolic color name, returns the red, green, blue components 2708of the color. In a scalar context, returns an array reference to the 2709rgb triplet. Returns undef for an invalid color name. 2710 2711=item @rgb = $panel-E<gt>rgb($index) 2712 2713Given a GD color index (between 0 and 140), returns the RGB triplet 2714corresponding to this index. This method is only useful within a 2715glyph's draw() routine, after the panel has allocated a GD::Image and 2716is populating it. 2717 2718=item $index = $panel-E<gt>translate_color($color) 2719 2720Given a color, returns the GD::Image index. The color may be 2721symbolic, such as "turquoise", or a #RRGGBB triple, as in #F0E0A8. 2722This method is only useful within a glyph's draw() routine, after the 2723panel has allocated a GD::Image and is populating it. 2724 2725=item $panel-E<gt>set_pen($width,$color) 2726 2727Changes the width and color of the GD drawing pen to the values 2728indicated. This is called automatically by the GlyphFactory fgcolor() 2729method. It returns the GD value gdBrushed, which should be used for 2730drawing. 2731 2732=back 2733 2734=head2 Creating Imagemaps 2735 2736You may wish to use Bio::Graphics to create clickable imagemaps for 2737display on the web. The main method for achieving this is 2738image_and_map(). Under special circumstances you may instead wish to 2739call either or both of create_web_image() and create_web_map(). 2740 2741Here is a synopsis of how to use image_and_map() in a CGI script, 2742using 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 2755We call image_and_map() with various arguments (described below) to 2756generate a three element list consisting of the URL at which the image 2757can be accessed, an HTML fragment containing the clickable imagemap 2758data, and the name of the map. We print out an E<lt>imageE<gt> tag 2759that uses the URL of the map as its src attribute and the name of the 2760map as the value of its usemap attribute. It is important to note 2761that we must put a "#" in front of the name of the map in order to 2762indicate that the map can be found in the same document as the 2763E<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 2769Create the image in a web-accessible directory and return its URL, its 2770clickable imagemap, and the name of the imagemap. The following 2771options 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 2797This method returns a three element list consisting of the URL at 2798which the image has been written to, the imagemap HTML, and the name 2799of the map. Usually you will incorporate this information into an 2800HTML 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 2809Create the image, write it into the directory indicated by 2810concatenating $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 2814Create a clickable imagemap named "mapname" using the indicated rules 2815to generate the hypertext links, the element titles, and the window 2816targets for the graphical elements. Return the HTML for the map, 2817including the enclosing E<lt>mapE<gt> tag itself. 2818 2819=back 2820 2821To use this method effectively, you will need a web server and an 2822image directory in the document tree that is writable by the web 2823server user. For example, if your web server's document root is 2824located 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 2830The 1777 privilege will allow anyone to create files and 2831subdirectories in this directory, but only the owner of the file will 2832be able to delete it. 2833 2834When you call image_and_map(), you must provide it with two vital 2835pieces of information: the URL of the image directory and the physical 2836location of the web server's document tree. In our example, you would 2837call: 2838 2839 $panel->image_and_map(-root => '/var/www/html',-url=>'/tmpimages'); 2840 2841If you are working with virtual hosts, you might wish to provide the 2842hostname: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 2847If you do not provide the -root argument, the method will try to 2848figure it out from the DOCUMENT_ROOT environment variable. If you do 2849not provide the -url argument, the method will assume "/tmp". 2850 2851During execution, the image_and_map() method will generate a unique 2852name for the image using the Digest::MD5 module. You can get this 2853module on CPAN and it B<must> be installed in order to use 2854image_and_map(). The imagename will be a long hexadecimal string such 2855as "e7457643f12d413f20843d4030c197c6.png". Its URL will be 2856/tmpimages/e7457643f12d413f20843d4030c197c6.png, and its physical path 2857will be /var/www/html/tmpimages/e7457643f12d413f20843d4030c197c6.png 2858 2859In addition to providing directory information, you must also tell 2860image_and_map() how to create outgoing links for each graphical 2861feature, and, optionally, how to create the "hover title" (the popup 2862yellow box displayed by most modern browsers), and the name of the 2863window or frame to link to when the user clicks on it. 2864 2865There are three ways to specify the link destination: 2866 2867=over 4 2868 2869=item 1. 2870 2871By configuring one or more tracks with a -link argument. 2872 2873=item 2. 2874 2875By configuring the panel with a -link argument. 2876 2877=item 3. 2878 2879By passing a -link argument in the call to image_and_map(). 2880 2881=back 2882 2883The -link argument can be either a string or a coderef. If you pass a 2884string, it will be interpreted as a URL pattern containing runtime 2885variables. These variables begin with a dollar sign ($), and are 2886replaced at run time with the information relating to the selected 2887annotation. 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 2903For example, to link each feature to a Google search on the feature's 2904description, use the argument: 2905 2906 -link => 'http://www.google.com/search?q=$description' 2907 2908Be sure to use single quotes around the pattern, or Perl will attempt 2909to perform variable interpretation before image_and_map() has a chance 2910to work on it. 2911 2912You may also pass a code reference to -link, in which case the code 2913will be called every time a URL needs to be generated for the 2914imagemap. The subroutine will be called with two arguments, the 2915feature and the Bio::Graphics::Panel object, and it should return the 2916URL to link to, or an empty string if a link is not desired. Here is a 2917simple 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 2929The -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 2931will look in the Panel configuration (created during 2932Bio::Graphics::Panel-E<gt>new). If no -link configuration option is found 2933in either location, then image_and_map() will use the value of -link 2934passed in its argument list, if any. 2935 2936The -title and -target options behave in a similar manner to -link. 2937-title is used to assign each feature "title" and "alt" attributes. 2938The "title" attribute is used by many browsers to create a popup hints 2939box when the mouse hovers over the feature's glyph for a preset length 2940of time, while the "alt" attribute is used to create navigable menu 2941items for the visually impaired. As with -link, you can set the title 2942by passing either a substitution pattern or a code ref, and the -title 2943option can be set in the track, the panel, or the method call itself 2944in that order of priority. 2945 2946If not provided, image_and_map() will autogenerate its own title in 2947the form "E<lt>methodE<gt> E<lt>display_nameE<gt> E<lt>seqidE<gt>:start..end". 2948 2949The -target option can be used to specify the window or frame that 2950clicked features will link to. By default, when the user clicks on a 2951feature, the loaded URL will replace the current page. You can modify 2952this by providing -target with the name of a preexisting or new window 2953name in order to create effects like popup windows, multiple frames, 2954popunders and the like. The value of -target follows the same rules 2955as -title and -link, including variable substitution and the use of 2956code refs. 2957 2958NOTE: Each time you call image_and_map() it will generate a new image 2959file. Images that are identical to an earlier one will reuse the same 2960name, but those that are different, even by one pixel, will result in 2961the generation of a new image. If you have limited disk space, you 2962might wish to check the images directory periodically and remove those 2963that have not been accessed recently. The following cron script will 2964remove image files that haven't been accessed in more than 20 days. 2965 296630 2 * * * find /var/www/html/tmpimages -type f -atime +20 -exec rm {} \; 2967 2968=head1 BUGS 2969 2970Please report them. 2971 2972=head1 SEE ALSO 2973 2974L<Bio::Graphics::Glyph>, 2975L<Bio::Graphics::Glyph::arrow>, 2976L<Bio::Graphics::Glyph::cds>, 2977L<Bio::Graphics::Glyph::crossbox>, 2978L<Bio::Graphics::Glyph::diamond>, 2979L<Bio::Graphics::Glyph::dna>, 2980L<Bio::Graphics::Glyph::dot>, 2981L<Bio::Graphics::Glyph::ellipse>, 2982L<Bio::Graphics::Glyph::extending_arrow>, 2983L<Bio::Graphics::Glyph::generic>, 2984L<Bio::Graphics::Glyph::graded_segments>, 2985L<Bio::Graphics::Glyph::heterogeneous_segments>, 2986L<Bio::Graphics::Glyph::line>, 2987L<Bio::Graphics::Glyph::pinsertion>, 2988L<Bio::Graphics::Glyph::primers>, 2989L<Bio::Graphics::Glyph::rndrect>, 2990L<Bio::Graphics::Glyph::segments>, 2991L<Bio::Graphics::Glyph::redgreen_box>, 2992L<Bio::Graphics::Glyph::ruler_arrow>, 2993L<Bio::Graphics::Glyph::toomany>, 2994L<Bio::Graphics::Glyph::transcript>, 2995L<Bio::Graphics::Glyph::transcript2>, 2996L<Bio::Graphics::Glyph::translation>, 2997L<Bio::Graphics::Glyph::triangle>, 2998L<Bio::Graphics::Glyph::xyplot>, 2999L<Bio::Graphics::Glyph::whiskerplot>, 3000L<Bio::SeqI>, 3001L<Bio::SeqFeatureI>, 3002L<Bio::Das>, 3003L<GD> 3004L<GD::SVG> 3005L<glyph_help.pl> 3006 3007=head1 AUTHOR 3008 3009Lincoln Stein E<lt>lstein@cshl.orgE<gt> 3010 3011Copyright (c) 2001 Cold Spring Harbor Laboratory 3012 3013This library is free software; you can redistribute it and/or modify 3014it under the same terms as Perl itself. See DISCLAIMER.txt for 3015disclaimers of warranty. 3016 3017=cut 3018 3019