1package Bio::Graphics::Glyph; 2 3use strict; 4use Carp 'croak','cluck'; 5use constant BUMP_SPACING => 2; # vertical distance between bumped glyphs 6use Bio::Root::Version; 7use Bio::Graphics::Layout; 8 9use Memoize 'memoize'; 10memoize('options') unless $^O =~ /mswin/i; 11# memoize('option',NORMALIZER=>'_normalize_objects'); # helps ?? 12# my %OptionCache; # works better? 13 14use base qw(Bio::Root::Root); 15 16my %LAYOUT_COUNT; 17our @FEATURE_STACK; 18 19# the CM1 and CM2 constants control the size of the hash used to 20# detect collisions. 21use constant CM1 => 20; # big bin, x axis 22use constant CM2 => 20; # big bin, y axis 23use constant CM3 => 50; # small bin, x axis 24use constant CM4 => 50; # small bin, y axis 25use constant INF => 1<<16; 26use constant NINF => -INF(); 27use constant DEBUG => 0; 28 29use constant QUILL_INTERVAL => 8; # number of pixels between Jim Kent style intron "quills" 30 31 32########################################################## 33# glyph-specific options 34# 35# the data structure returned by my_options will be merged 36# with values returned by this method in subclasses to 37# create a merged hash of all options that can be invoked 38# 39# retrieve this merged hash with 40# Bio::Graphics::Glyph::the_subclass->options 41# 42########################################################## 43sub my_description { 44 return <<END; 45This is the base class for all glyphs. It knows how to draw simple 46filled and empty boxes. You will want to use the "generic" or 47"box" glyphs instead of this one. 48END 49} 50 51sub my_options { 52 return 53 { 54 height => [ 55 'integer', 56 10, 57 'Height of the glyph.'], 58 box_subparts=> [ 59 'integer', 60 0, 61 'If this option is greater than zero, then imagemaps constructed from this glyph will contain', 62 'bounding boxes around each subpart of a feature (e.g. each exon in a gene). The value of the', 63 'option indicates the depth of recursion.' 64 ], 65 fgcolor => [ 66 ['color','featureScore','featureRGB'], 67 'black', 68 'The foreground color of the glyph, used for drawing outlines.', 69 'A value of "featureScore" will produce a greyscale gradient from the', 70 "feature's score value based on a range from 0 (lightest) to 1000 (darkest).", 71 'A value of "featureRGB" will look for a feature tag named "RGB" and use that', 72 'for the color value.', 73 'See the next section for color choices.'], 74 bgcolor => [ 75 ['color','featureScore','featureRGB'], 76 'turquoise', 77 'The background color of the glyph, used for filling its contents.', 78 'A value of "featureScore" will produce a greyscale gradient from the', 79 "feature's score value based on a range from 0 (lightest) to 1000 (darkest).", 80 'A value of "featureRGB" will look for a feature tag named "RGB" and use that', 81 'for the color value.', 82 'See the next section for color choices.'], 83 fillcolor => [ 84 'color', 85 'turquoise', 86 'A synonym for -bgcolor.'], 87 tkcolor => [ 88 'color', 89 undef, 90 'Rarely-used option to flood-fill entire glyph with a single color', 91 'prior to rendering it.'], 92 opacity => [ 93 'float', 94 '1.0', 95 'Default opacity to apply to glyph background and foreground colors.', 96 'This is a value between 0.0 (completely transparent) to 1.0 (completely opaque.', 97 'If the color contains an explicit opacity (alpha) value, the default value', 98 'will be ignored'], 99 linewidth => [ 100 'integer', 101 1, 102 'Thickness of line used to draw the glyph\'s outline.'], 103 strand_arrow => [ 104 'boolean', 105 undef, 106 "Whether to indicate the feature's strandedness. If equal to 'ends'", 107 "then only the right and left ends of multi-part features will show", 108 "strandedness." 109 ], 110 stranded => [ 111 'boolean', 112 undef, 113 'Synonym for -strand_arrow.', 114 "Indicates whether to indicate the feature's strandedness. If equal to 'ends'", 115 "then only the right and left ends of multi-part features will show", 116 "strandedness." 117 118 ], 119 key => [ 120 'string', 121 undef, 122 'The printed label to use to describe this track.'], 123 category => [ 124 'string', 125 undef, 126 'A descriptive category that will be added to the track key.'], 127 no_subparts => [ 128 'boolean', 129 undef, 130 'Set this option to a true value to suppress drawing of all its subparts.'], 131 ignore_sub_part => [ 132 'string', 133 undef, 134 'Pass a space-delimited list of primary_tag() names in order to selectively', 135 'suppress the drawing of subparts that match those primary tags.'], 136 maxdepth => [ 137 'integer', 138 undef, 139 'Specifies how many levels deep the glyph should traverse features looking', 140 'for subfeatures. A value of undef allows unlimited traversal. A value of', 141 '0 suppresses traversal entirely for the same effect as -no_subparts.'], 142 sort_order => [ 143 ['left','right','low_score','high_score','longest','shortest','strand','name'], 144 'left', 145 'Control how features are layed out so that more "important" features sort', 146 'towards the top. See the Bio::Graphics::Glyph documentation for a description of how this' , 147 'works.'], 148 always_sort => [ 149 'boolean', 150 undef, 151 'Sort even when bumping is off.'], 152 bump => [ 153 'integer', 154 1, 155 'This option dictates the behavior of the glyph when two features collide horizontally.', 156 'A value of +1 will bump the colliding feature downward using an algorithm that uses spaces efficiently.', 157 'A value of -1 will bump the colliding feature upward using the same algorithm.', 158 'Values of +2 and -2 will bump using a simple algorithm that is faster but does not use space as efficiently.', 159 'A value of 3 or "fast" will turn on a faster collision detection algorithm which', 160 'is only compatible with the default "left" sorting order.', 161 'A value of 0 suppresses collision control entirely.'], 162 bump_limit => [ 163 'integer', 164 -1, 165 'This option will cause bumping to stop after the indicated number of features', 166 'pile up. Subsequent collisions will not be bumped.'], 167 feature_limit => [ 168 'integer', 169 0, 170 'This option will set an upper bound on the number of features to be displayed.', 171 'For this to work properly, features must be added one at a time using add_feature().'], 172 hbumppad => [ 173 'integer', 174 2, 175 'Ordinarily collison control prevents two features from overlapping if they come within', 176 '2 pixels of each other. This option allows you to change this value to give glyphs', 177 'more or less breathing space on the left and right.' 178 ], 179 hilite => [ 180 'color', 181 undef, 182 'Highlight the glyph in the indicated color. Usually used as a callback to', 183 'selectively highlight glyphs that meet certain criteria.'], 184 link => [ 185 'string', 186 undef, 187 'When generating an imagemap, specify the pattern or callback for formatting', 188 'the link URL associated with the glyph.'], 189 title => [ 190 'string', 191 undef, 192 'When generating an imagemap, specify the pattern or callback for formatting', 193 'the link title associated with the glyph.'], 194 target => [ 195 'string', 196 undef, 197 'When generating an imagemap, specify the pattern or callback for formatting', 198 'the link target associated with the glyph.'], 199 }; 200} 201 202# return a demo feature for the user to play with 203# The feature must not be longer than 500 bp for this to work. 204# Default is to return nothing. 205sub demo_feature { 206 return; 207} 208 209sub gd { shift->panel->current_gd } 210 211# a bumpable graphical object that has bumpable graphical subparts 212 213# args: -feature => $feature_object (may contain subsequences) 214# -factory => $factory_object (called to create glyphs for subsequences) 215# In this scheme, the factory decides based on stylesheet information what glyph to 216# draw and what configurations options to us. This allows for heterogeneous tracks. 217sub new { 218 my $class = shift; 219 my %arg = @_; 220 221 my $feature = $arg{-feature} or $class->throw("No feature $class"); 222 my $factory = $arg{-factory} || $class->default_factory; 223 my $level = $arg{-level} || 0; 224 my $flip = $arg{-flip}; 225 226 push @FEATURE_STACK,($feature,undef); 227 228 my $self = bless {},$class; 229 $self->{feature} = $feature; 230 $self->{factory} = $factory; 231 $self->{level} = $level; 232 $self->{flip}++ if $flip; 233 $self->{top} = 0; 234 235 my $panel = $factory->panel; 236 my $p_start = $panel->start; 237 my $p_end = $panel->end; 238 239 my @subfeatures; 240 my @subglyphs; 241 242 warn $self if DEBUG; 243 warn $feature if DEBUG; 244 245 @subfeatures = $self->subfeat($feature); 246 247 if ($self->option('ignore_sub_part')) { 248 my @tmparray; 249 foreach (@subfeatures) { 250 my $type = $_->method; 251 252 my @ignore_list = split /\s+/, $self->option('ignore_sub_part'); 253 my $ignore_str = join('|', @ignore_list); 254 255 unless ($type =~ /$ignore_str/) { 256 push @tmparray, $_; 257 } 258 } 259 @subfeatures = @tmparray; 260 } 261 262 my @visible_subfeatures = grep {$p_start <= $_->end && $p_end >= $_->start} @subfeatures; 263 264 $self->feature_has_subparts(@subfeatures>0); 265 266 if (@visible_subfeatures) { 267 # dynamic glyph resolution 268 @subglyphs = map { $_->[0] } 269 sort { $a->[1] <=> $b->[1] } 270 map { [$_, $_->left ] } 271 $self->make_subglyph($level+1,@visible_subfeatures); 272 $self->{feature_count} = scalar @subglyphs; 273 $self->{parts} = \@subglyphs; 274 } 275 276# warn "type=",$feature->type,", glyph=$self, subglyphs=@subglyphs"; 277 278 my ($start,$stop) = ($self->start, $self->stop); 279 if (defined $start && defined $stop && $start ne '') { # more paranoia 280 ($start,$stop) = ($stop,$start) if $start > $stop; # sheer paranoia 281 # the +1 here is critical for allowing features to meet nicely at nucleotide resolution 282 my ($left,$right) = $factory->map_pt($start,$stop+1); 283 $self->{left} = $left; 284 $self->{width} = $right - $left + 1; 285 } 286 287 if (@subglyphs) { 288 my $l = $subglyphs[0]->left; 289 # this clashes with the pad_left calculation and is unecessary 290 # $self->{left} = $l if !defined($self->{left}) || $l < $self->{left}; 291 my $right = ( 292 sort { $b<=>$a } 293 map {$_->right} @subglyphs)[0]; 294 my $w = $right - $self->{left} + 1; 295 # this clashes with the pad_right calculation and is unecessary 296 # $self->{width} = $w if !defined($self->{width}) || $w > $self->{width}; 297 } 298 299 $self->{point} = $arg{-point} ? $self->height : undef; 300 splice(@FEATURE_STACK,-2); 301 return $self; 302} 303 304# override this if you want to make a particular type of glyph rather than have the 305# factory decide. 306sub make_subglyph { 307 my $self = shift; 308 my $level = shift; 309 my $factory = $self->{factory}; 310 $factory->make_glyph($level,@_); 311} 312 313sub parts { 314 my $self = shift; 315 return unless $self->{parts}; 316 return wantarray ? @{$self->{parts}} : $self->{parts}; 317} 318 319sub feature_count { 320 my $self = shift; 321 return $self->{feature_count} || 0; 322} 323 324sub features_clipped { 325 my $self = shift; 326 my $d = $self->{features_clipped}; 327 $self->{features_clipped} = shift if @_; 328 return $d; 329} 330 331sub _bump_feature_count { 332 my $self = shift; 333 my $count = shift || 1; 334 return $self->{feature_count} += $count; 335} 336 337# this is different than parts(). parts() will return subglyphs 338# that are contained within the current viewing range. feature_has_subparts() 339# will return true if the feature has any subparts, even if they are off the 340# screen. 341sub feature_has_subparts { 342 my $self = shift; 343 344 return $self->{feature_has_subparts} = shift if @_; 345 return 0 if $self->maxdepth == 0; 346 my $feature = $self->feature; 347 return 1 if $feature->can('compound') && $feature->compound; 348 return $self->{feature_has_subparts}; 349} 350 351sub feature { shift->{feature} } 352sub factory { shift->{factory} } 353sub panel { shift->factory->panel } 354sub point { shift->{point} } 355sub scale { shift->factory->scale } 356sub flip { 357 my $self = shift; 358 my $d = $self->{flip}; 359 $self->{flip} = shift if @_; 360 $d; 361} 362sub start { 363 my $self = shift; 364 return $self->{start} if exists $self->{start}; 365 if ($self->{flip}) { 366 $self->{start} = defined $self->{feature}->end 367 ? $self->panel->end + 1 - $self->{feature}->end 368 : 0; 369 } else { 370 $self->{start} = defined $self->{feature}->start 371 ? $self->{feature}->start 372 : $self->panel->offset - 1 373 } 374 375 return $self->{start}; 376} 377 378sub stop { 379 my $self = shift; 380 return $self->{stop} if exists $self->{stop}; 381 if ($self->{flip}) { 382 $self->{stop} = defined $self->{feature}->start 383 ? $self->panel->end + 1 - $self->{feature}->start 384 : $self->panel->offset - 1; 385 } else { 386 $self->{stop} = defined $self->{feature}->end 387 ? $self->{feature}->end 388 : $self->panel->offset+$self->panel->length+1; 389 } 390 391 return $self->{stop} 392} 393sub end { shift->stop } 394sub length { my $self = shift; $self->stop - $self->start }; 395sub score { 396 my $self = shift; 397 return $self->{score} if exists $self->{score}; 398 return $self->{score} = ($self->{feature}->score || 0); 399} 400sub strand { 401 my $self = shift; 402 return $self->{strand} if exists $self->{strand}; 403 return $self->{strand} = ($self->{feature}->strand || 0); 404} 405sub map_pt { shift->{factory}->map_pt(@_) } 406sub map_no_trunc { shift->{factory}->map_no_trunc(@_) } 407 408# add a feature (or array ref of features) to the list 409sub add_feature { 410 my $self = shift; 411 my $factory = $self->factory; 412 413 for my $feature (@_) { 414 if (ref $feature eq 'ARRAY') { 415 $self->add_group(@$feature); 416 $self->_bump_feature_count(scalar @$feature); 417 } else { 418 warn $factory if DEBUG; 419 my $parts = $self->{parts} ||= []; 420 my $limit = $self->feature_limit; 421 my $count = $self->_bump_feature_count; 422 423 if (!$limit || $count <= $limit) { 424 push @$parts,$factory->make_glyph(0,$feature); 425 } elsif (rand() < $limit/$count) { 426 $self->features_clipped(1); 427 $parts->[rand @$parts] = $factory->make_glyph(0,$feature); # subsample 428 } 429 430 } 431 } 432} 433 434# link a set of features together so that they bump as a group 435sub add_group { 436 my $self = shift; 437 my @features = ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_; 438 my $f = Bio::Graphics::Feature->new( 439 -segments=>\@features, 440 -type => 'group', 441 ); 442 $self->add_feature($f); 443 $f; 444} 445 446sub top { 447 my $self = shift; 448 my $g = $self->{top}; 449 $self->{top} = shift if @_; 450 $g; 451} 452sub left { 453 my $self = shift; 454 return $self->{left} - $self->pad_left; 455} 456sub right { 457 my $self = shift; 458 return $self->left + $self->layout_width - 1; 459} 460sub bottom { 461 my $self = shift; 462 $self->top + $self->layout_height - 1; 463} 464sub height { 465 my $self = shift; 466 return $self->{height} if exists $self->{height}; 467 my $baseheight = $self->option('height'); # what the factory says 468 return $self->{height} = $baseheight; 469} 470sub width { 471 my $self = shift; 472 my $g = $self->{width}; 473 $self->{width} = shift if @_; 474 return $g; 475} 476sub layout_height { 477 my $self = shift; 478 push @FEATURE_STACK,$self->feature; 479 my $result = $self->layout; 480 pop @FEATURE_STACK; 481 return $result; 482} 483sub layout_width { 484 my $self = shift; 485 return $self->width + $self->pad_left + $self->pad_right; 486} 487 488# returns the rectangle that surrounds the physical part of the 489# glyph, excluding labels and other "extra" stuff 490sub calculate_boundaries {return shift->bounds(@_);} 491 492sub bounds { 493 my $self = shift; 494 my ($dx,$dy) = @_; 495 $dx += 0; $dy += 0; 496 497 ($dx + $self->{left}, 498 $dy + $self->top + $self->pad_top, 499 $dx + $self->{left} + $self->{width} - 1, 500 $dy + $self->bottom - $self->pad_bottom); 501} 502 503sub box { 504 my $self = shift; 505 my @result = ($self->left,$self->top,$self->right,$self->bottom); 506 return @result; 507} 508 509sub unfilled_box { 510 my $self = shift; 511 my $gd = shift; 512 my ($x1,$y1,$x2,$y2,$fg,$bg,$lw) = @_; 513 $lw = $self->linewidth; 514 515 unless ($fg) { 516 $fg ||= $self->fgcolor; 517 $fg = $self->set_pen($lw,$fg) if $lw > 1; 518 } 519 520 unless ($bg) { 521 $bg ||= $self->bgcolor; 522 $bg = $self->set_pen($lw,$bg) if $lw > 1; 523 } 524 525 # draw a box 526 $gd->rectangle($x1,$y1,$x2,$y2,$fg); 527 528 # if the left end is off the end, then cover over 529 # the leftmost line 530 my ($width) = $gd->getBounds; 531 532 $gd->line($x1,$y1+$lw,$x1,$y2-$lw,$bg) 533 if $x1 < $self->panel->pad_left; 534 535 $gd->line($x2,$y1+$lw,$x2,$y2-$lw,$bg) 536 if $x2 > $width - $self->panel->pad_right; 537} 538 539# return boxes surrounding each part 540sub boxes { 541 my $self = shift; 542 543 push @FEATURE_STACK,$self->feature; 544 545 my ($left,$top,$parent) = @_; 546 $top += 0; $left += 0; 547 my @result; 548 549 $self->layout; 550 $parent ||= $self; 551 my $subparts = $self->box_subparts || 0; 552 553 for my $part ($self->parts) { 554 my $type = $part->feature->primary_tag || ''; 555 if ($type eq 'group' or $subparts > $part->level) { 556 push @result,$part->boxes($left,$top+$self->top+$self->pad_top,$parent); 557 next if $type eq 'group'; 558 } 559 my ($x1,$y1,$x2,$y2) = $part->box; 560 $x2++ if $x1==$x2; 561 push @result,[$part->feature, 562 $left + $x1,$top+$self->top+$self->pad_top+$y1, 563 $left + $x2,$top+$self->top+$self->pad_top+$y2, 564 $parent]; 565 } 566 567 pop @FEATURE_STACK; 568 return wantarray ? @result : \@result; 569 } 570 571 sub box_subparts { 572 my $self = shift; 573 return $self->{box_subparts} if exists $self->{box_subparts}; 574 return $self->{box_subparts} = $self->_box_subparts; 575 } 576 577 sub _box_subparts { shift->option('box_subparts') } 578 579 # this should be overridden for labels, etc. 580 # allows glyph to make itself thicker or thinner depending on 581 # domain-specific knowledge 582 sub pad_top { 583 my $self = shift; 584 return 0; 585 } 586 sub pad_bottom { 587 my $self = shift; 588 return 0; 589 } 590 sub pad_left { 591 my $self = shift; 592 my @parts = $self->parts or return 0; 593 my $max = 0; 594 foreach (@parts) { 595 my $pl = $_->pad_left; 596 $max = $pl if $max < $pl; 597 } 598 $max; 599 } 600 sub pad_right { 601 my $self = shift; 602 my @parts = $self->parts or return 0; 603 my $max = 0; 604 my $max_right = 0; 605 foreach (@parts) { 606 my $right = $_->right; 607 my $pr = $_->pad_right; 608 if ($max_right < $pr+$right) { 609 $max = $pr; 610 $max_right = $pr+$right; 611 } 612 } 613 $max; 614 } 615 616 # move relative to parent 617 sub move { 618 my $self = shift; 619 my ($dx,$dy) = @_; 620 $self->{left} += $dx; 621 $self->{top} += $dy; 622 623 # because the feature parts use *absolute* not relative addressing 624 # we need to move each of the parts horizontally, but not vertically 625 $_->move($dx,0) foreach $self->parts; 626 } 627 628 # get an option 629 sub option { 630 my $self = shift; 631 my $option_name = shift; 632 local $^W=0; 633 my @args = ($option_name,@{$self}{qw(partno total_parts)}); 634 my $factory = $self->{factory} or return; 635 return $factory->option($self,@args); 636} 637 638# get an option that might be a code reference 639sub code_option { 640 my $self = shift; 641 my $option_name = shift; 642 my $factory = $self->factory or return; 643 $factory->get_option($option_name); 644} 645 646# set an option globally 647sub configure { 648 my $self = shift; 649 my $factory = $self->factory; 650 my $option_map = $factory->option_map; 651 while (@_) { 652 my $option_name = shift; 653 my $option_value = shift; 654 ($option_name = lc $option_name) =~ s/^-//; 655 $option_map->{$option_name} = $option_value; 656 } 657} 658 659# some common options 660sub color { 661 my $self = shift; 662 my $color = shift; 663 my $index = $self->option($color); 664 # turn into a color index 665 return $self->translate_color($index) if defined $index; 666 return 0; 667} 668 669sub translate_color { 670 my $self = shift; 671 my $color = shift; 672 return $self->_translate_color($color); 673} 674 675sub _translate_color { 676 my $self = shift; 677 my $color = shift; 678 my $opacity = $self->default_opacity; 679 return $opacity < 1 ? $self->factory->transparent_color($opacity,$color) 680 : $self->factory->translate_color($color); 681} 682 683# return value: 684# 0 no bumping 685# +1 bump down 686# -1 bump up 687# +2 simple bump down 688# -2 simple bump up 689# +3 optimized (fast) bumping 690sub bump { 691 my $self = shift; 692 my $bump = $self->option('bump'); 693 return $bump; 694} 695 696# control horizontal and vertical collision control 697sub hbumppad { 698 my $self = shift; 699 return $self->{_hbumppad} if exists $self->{_hbumppad}; 700 my $hbumppad = $self->option('hbumppad'); 701 $hbumppad = 2 unless defined $hbumppad; 702 return $self->{_hbumppad}= $hbumppad; 703} 704 705sub default_opacity { 706 my $self = shift; 707 return $self->{default_opacity} if defined $self->{default_opacity}; 708 my $o = $self->option('opacity'); 709 return $self->{default_opacity} = defined $o ? $o : 1.0; 710} 711 712# we also look for the "color" option for Ace::Graphics compatibility 713sub fgcolor { 714 my $self = shift; 715 my $fgcolor = $self->option('color') || $self->option('fgcolor'); 716 717 my $index = $fgcolor; 718 $index = 'black' unless defined $index; 719 720 if ($index eq 'featureRGB') { 721 ($index) = eval{$self->feature->get_tag_values('RGB')}; 722 $index ||= $fgcolor; 723 } elsif ($index eq 'featureScore') { 724 $index = $self->score_to_color; 725 } 726 return $self->_translate_color($index); 727} 728 729#add for compatibility 730sub fillcolor { 731 my $self = shift; 732 return $self->bgcolor; 733} 734 735# we also look for the "fillcolor" option for Ace::Graphics compatibility 736sub bgcolor { 737 my $self = shift; 738 my ($bgcolor) = eval{$self->feature->get_tag_values('bgcolor')}; 739 $bgcolor ||= $self->option('bgcolor'); # Let feature attribute override color 740 my $index = defined $bgcolor ? $bgcolor : $self->option('fillcolor'); 741 $index = 'white' unless defined $index; 742 743 if ($index eq 'featureRGB') { 744 ($index) = eval{$self->feature->get_tag_values('RGB')}; 745 $index ||= $bgcolor; 746 } elsif ($index eq 'featureScore') { 747 $index = $self->score_to_color; 748 } 749 return $self->_translate_color($index); 750} 751 752# for compatibility with UCSC genome browser useScore option 753sub score_to_color { 754 my $self = shift; 755 my $feature = $self->feature; 756 757 my ($score) = $feature->can('score') ? $feature->score 758 : eval{$feature->has_tag('score')} || 0; 759 760 my $max_score = 945; # defined by UCSC docs 761 my $min_score = 166; 762 my $min_gray = 0; 763 my $max_gray = 255; 764 my $rgb_per_score = ($max_gray-$min_gray)/($max_score-$min_score); 765 766 $score = $max_score if $score > $max_score; 767 $score = $min_score if $score < $min_score; 768 769 my $gray = int($max_gray - ($min_gray + ($score-$min_score) * $rgb_per_score)); 770 return "rgb($gray,$gray,$gray)"; 771} 772 773sub getfont { 774 my $self = shift; 775 my $option = shift || 'font'; 776 my $default = shift; 777 778 my $font = $self->option($option) || $default; 779 return unless $font; 780 781 my $gdfont = $self->panel->gdfont($font); 782 $self->configure($option => $gdfont); 783 return $gdfont; 784} 785 786sub tkcolor { # "track color" 787 my $self = shift; 788 $self->option('tkcolor') or return; 789 return $self->color('tkcolor') 790} 791sub image_class { shift->{factory}->{panel}->{image_class}; } 792sub polygon_package { shift->{factory}->{panel}->{polygon_package}; } 793 794sub layout_sort { 795 my $self = shift; 796 my $sortfunc; 797 798 my $opt = $self->code_option("sort_order"); 799 800 if (!$opt) { 801 $sortfunc = sub { $a->start <=> $b->start }; 802 } elsif (ref $opt eq 'CODE') { 803 $self->throw('sort_order subroutines must use the $$ prototype') 804 unless prototype($opt) eq '$$'; 805 $sortfunc = $opt; 806 } elsif ($opt =~ /^sub\s+\{/o) { 807 $sortfunc = eval $opt; 808 } else { 809 # build $sortfunc for ourselves: 810 my @sortbys = split(/\s*\|\s*/o, $opt); 811 $sortfunc = 'sub { '; 812 my $sawleft = 0; 813 814 # not sure I can make this schwartzian transformed 815 for my $sortby (@sortbys) { 816 if ($sortby eq "left" || $sortby eq "default") { 817 $sortfunc .= '($a->start <=> $b->start) || '; 818 $sawleft++; 819 } elsif ($sortby eq "right") { 820 $sortfunc .= '($a->end <=> $b->end) || '; 821 } elsif ($sortby eq "low_score") { 822 $sortfunc .= '($a->score <=> $b->score) || '; 823 } elsif ($sortby eq "high_score") { 824 $sortfunc .= '($b->score <=> $a->score) || '; 825 } elsif ($sortby eq "longest") { 826 $sortfunc .= '(($b->length) <=> ($a->length)) || '; 827 } elsif ($sortby eq "shortest") { 828 $sortfunc .= '(($a->length) <=> ($b->length)) || '; 829 } elsif ($sortby eq "strand") { 830 $sortfunc .= '($b->strand <=> $a->strand) || '; 831 } elsif ($sortby eq "name") { 832 $sortfunc .= '($a->feature->display_name cmp $b->feature->display_name) || '; 833 } 834 } 835 unless ($sawleft) { 836 $sortfunc .= ' ($a->left <=> $b->left) '; 837 } else { 838 $sortfunc .= ' 0'; 839 } 840 $sortfunc .= '}'; 841 $sortfunc = eval $sortfunc; 842 } 843 844 # cache this 845 # $self->factory->set_option(sort_order => $sortfunc); 846 my @things = sort $sortfunc @_; 847 return @things; 848} 849 850# handle collision detection 851sub layout { 852 my $self = shift; 853 854 return $self->{layout_height} if exists $self->{layout_height}; 855 856 my @parts = $self->parts; 857 return $self->{layout_height} = 858 $self->height + $self->pad_top + $self->pad_bottom unless @parts; 859 860 my $bump_direction = $self->bump; 861 my $bump_limit = $self->bump_limit || -1; 862 863 $bump_direction = 'fast' if 864 $bump_direction && 865 $bump_direction == 1 && 866 !$self->code_option('sort_order'); 867 868 $_->layout foreach @parts; # recursively lay out 869 870 # no bumping requested, or only one part here, or the tracks are supposed to be overlay 871 if (@parts == 1 || !$bump_direction || ($bump_direction eq 'fast' and $self->code_option('overlay') == 1)) { 872 my $highest = 0; 873 foreach (@parts) { 874 my $height = $_->layout_height; 875 $highest = $height > $highest ? $height : $highest; 876 } 877 return $self->{layout_height} = $highest + $self->pad_top + $self->pad_bottom; 878 } 879 880 if ($bump_direction eq 'fast' or $bump_direction == 3) { 881 return $self->{layout_height} = $self->optimized_layout(\@parts) 882 + $self->pad_bottom + $self->pad_top -1;# - $self->top + 1; 883 } 884 885 my (%bin1,%bin2); 886 my $limit = 0; 887 my $recent_pos = 0; 888 my $max_pos = 0; 889 890 # strand bumping turns on bumping for features that are in opposite strands! 891 # features in the same strand are allowed to overlap 892 my $strand_bumping; 893 if ($bump_direction eq 'overlap') { 894 $bump_direction = 1; 895 $strand_bumping++; 896 } 897 898 for my $g ($self->layout_sort(@parts)) { 899 900 my $height = $g->{layout_height}; 901 902 # Simple +/- 2 bumping. Every feature gets its very own line 903 if (abs($bump_direction) >= 2) { 904 $g->move(0,$limit); 905 $limit += $height + BUMP_SPACING if $bump_direction > 0; 906 $limit -= $height + BUMP_SPACING if $bump_direction < 0; 907 next; 908 } 909 910 # we get here for +/- 1 bumping 911 my $pos = 0; 912 my $bumplevel = 0; 913 my $left = $g->left; 914 my $right = $g->right; 915 my $strand = $g->strand || 0; 916 917 my $search_mode = 'down'; 918 919 while (1) { 920 921 # stop bumping if we've gone too far down 922 if ($bump_limit > 0 && $bumplevel++ >= $bump_limit) { 923 $g->{overbumped}++; # this flag can be used to suppress label and description 924 foreach ($g->parts) { 925 $_->{overbumped}++; 926 } 927 last; 928 } 929 930 # look for collisions 931 my $bottom = $pos + $height; 932 my $bin = \%bin1; 933 $bin = $strand >= 0 ? \%bin1 : \%bin2 if $strand_bumping; 934 my $collision = $self->collides($bin,CM1,CM2,$left,$pos,$right,$bottom) or last; 935 936 if ($bump_direction > 0) { 937 $pos = $collision->[3] + BUMP_SPACING; # collision, so bump 938 } else { 939 $pos -= BUMP_SPACING; 940 } 941 942 $pos++ if $pos % 2; # correct for GD rounding errors 943 } 944 945 $g->move(0,$pos); 946 947 my $bin = \%bin1; 948 $bin = $strand >= 0 ? \%bin2 : \%bin1 if $strand_bumping; # note reversed order - features in opposite strands bump 949 $self->add_collision($bin,CM1,CM2,$left,$g->top,$right,$g->bottom); 950 951 $recent_pos = $pos; 952 $max_pos = $pos if $pos > $max_pos; 953 } 954 955 # If -1 bumping was allowed, then normalize so that the top glyph is at zero 956 if ($bump_direction < 0) { 957 my $topmost; 958 foreach (@parts) { 959 my $top = $_->top; 960 $topmost = $top if !defined($topmost) or $top < $topmost; 961 } 962 my $offset = - $topmost; 963 $_->move(0,$offset) foreach @parts; 964 } 965 966 # find new height 967 my $bottom = 0; 968 foreach (@parts) { 969 $bottom = $_->bottom if $_->bottom > $bottom; 970 } 971 return $self->{layout_height} = 972 $self->pad_bottom + $self->pad_top + $bottom - $self->top + 1; 973} 974 975# the $%occupied structure is a hash of {left,top} = [left,top,right,bottom] 976sub collides { 977 my $self = shift; 978 my ($occupied,$cm1,$cm2,$left,$top,$right,$bottom) = @_; 979 my @keys = $self->_collision_keys($cm1,$cm2,$left,$top,$right,$bottom); 980 my $hspacing = $self->hbumppad; 981 my $collides = 0; 982 for my $k (@keys) { 983 next unless exists $occupied->{$k}; 984 for my $bounds (@{$occupied->{$k}}) { 985 my ($l,$t,$r,$b) = @$bounds; 986 next unless $right+$hspacing > $l and $left-$hspacing < $r 987 and $bottom >= $t and $top <= $b; 988 $collides = $bounds; 989 last; 990 } 991 } 992 $collides; 993} 994 995sub add_collision { 996 my $self = shift; 997 my ($occupied,$cm1,$cm2,$left,$top,$right,$bottom) = @_; 998 my $value = [$left,$top,$right,$bottom]; 999 my @keys = $self->_collision_keys($cm1,$cm2,@$value); 1000 push @{$occupied->{$_}},$value foreach @keys; 1001} 1002 1003sub _collision_keys { 1004 my $self = shift; 1005 my ($binx,$biny,$left,$top,$right,$bottom) = @_; 1006 my @keys; 1007 my $bin_left = int($left/$binx); 1008 my $bin_right = int($right/$binx); 1009 my $bin_top = int($top/$biny); 1010 my $bin_bottom = int($bottom/$biny); 1011 for (my $x=$bin_left;$x<=$bin_right; $x++) { 1012 for (my $y=$bin_top;$y<=$bin_bottom; $y++) { 1013 push @keys,join(',',$x,$y); 1014 } 1015 } 1016 @keys; 1017} 1018 1019# jbrowse layout that acts by keeping track of contours of the free space 1020sub optimized_layout { 1021 my $self = shift; 1022 my $parts = shift; 1023 1024 my $hspacing = $self->hbumppad; 1025 my $bump_limit = $self->bump_limit; 1026 1027 my @rects = map { 1028 $_ => [ 1029 $_->left, 1030 $_->right + $hspacing, 1031 $_->{layout_height}+BUMP_SPACING 1032 ] 1033 } $self->layout_sort(@$parts); 1034 1035 my $layout = Bio::Graphics::Layout->new(0,$self->panel->right); 1036 my $overbumped; 1037 while (@rects) { 1038 my ($part,$rect) = splice(@rects,0,2); 1039 my $offset = $layout->addRect("$part",@$rect); 1040 if ($overbumped && $offset > $overbumped) { 1041 $part->move(0,$overbumped); 1042 next; 1043 } 1044 $part->move(0,$offset); 1045 $overbumped = $offset if $bump_limit > 0 && $offset >= $bump_limit * $rect->[2]; 1046 } 1047 return $overbumped && $overbumped < $layout->totalHeight ? $overbumped : $layout->totalHeight; 1048} 1049 1050sub draw_it { 1051 my $self = shift; 1052 push @FEATURE_STACK,$self->feature; 1053 $self->draw(@_); 1054 pop @FEATURE_STACK; 1055} 1056 1057sub draw { 1058 my $self = shift; 1059 my $gd = shift; 1060 my ($left,$top,$partno,$total_parts) = @_; 1061 1062 $self->panel->startGroup($gd); 1063 1064 my $connector = $self->connector; 1065 if (my @parts = $self->parts) { 1066 1067 # invoke sorter if user wants to sort always and we haven't already sorted 1068 # during bumping. 1069 @parts = $self->layout_sort(@parts) if !$self->bump && $self->option('always_sort'); 1070 1071 my $x = $left; 1072 my $y = $top + $self->top + $self->pad_top; 1073 1074 $self->draw_connectors($gd,$x,$y) if $connector && $connector ne 'none'; 1075 1076 my $last_x; 1077 for (my $i=0; $i<@parts; $i++) { 1078 # lie just a little bit to avoid lines overlapping and make the picture prettier 1079 my $fake_x = $x; 1080 $fake_x-- if defined $last_x && $parts[$i]->left - $last_x == 1; 1081 $parts[$i]->draw_highlight($gd,$fake_x,$y); 1082 $parts[$i]->draw_it($gd,$fake_x,$y,$i,scalar(@parts)); 1083 $last_x = $parts[$i]->right; 1084 } 1085 } 1086 1087 else { # no part 1088 $self->draw_connectors($gd,$left,$top) 1089 if $connector && $connector ne 'none'; # && $self->{level} == 0; 1090 $self->draw_component($gd,$left,$top,$partno,$total_parts) unless $self->feature_has_subparts; 1091 } 1092 1093 $self->panel->endGroup($gd); 1094} 1095 1096sub connector { return } 1097 1098sub parts_overlap { 1099 my $self = shift; 1100 return $self->option('parts_overlap'); 1101} 1102 1103sub bump_limit { shift->option('bump_limit') } 1104 1105# the "level" is the level of testing of the glyph 1106# groups are level -1, top level glyphs are level 0, subcomponents are level 1 and so forth. 1107sub level { 1108 shift->{level}; 1109} 1110 1111# return the feature's parent; 1112sub parent_feature { 1113 my $self = shift; 1114 my $ancestors = shift; 1115 $ancestors = 1 unless defined $ancestors; 1116 1117 return unless @FEATURE_STACK; 1118 1119 my $index = $#FEATURE_STACK - $ancestors; 1120 return unless $index >= 0; 1121 return $FEATURE_STACK[$index]; 1122} 1123 1124sub draw_connectors { 1125 my $self = shift; 1126 return if $self->{overbumped}; 1127 my $gd = shift; 1128 my ($dx,$dy) = @_; 1129 my @parts = sort { $a->left <=> $b->left } $self->parts; 1130 for (my $i = 0; $i < @parts-1; $i++) { 1131 # don't let connectors double-back on themselves 1132 next if ($parts[$i]->bounds)[2] > ($parts[$i+1]->bounds)[0] && !$self->parts_overlap; 1133 $self->_connector($gd,$dx,$dy,$parts[$i]->bounds,$parts[$i+1]->bounds); 1134 } 1135 1136 # extra connectors going off ends 1137 if (@parts) { 1138 my($x1,$y1,$x2,$y2) = $self->bounds(0,0); 1139 my($xl,$xt,$xr,$xb) = $parts[0]->bounds; 1140 $self->_connector($gd,$dx,$dy,$x1,$xt,$x1,$xb,$xl,$xt,$xr,$xb) if $x1 < $xl; 1141 1142 @parts = sort {$a->right<=>$b->right} @parts; 1143 my ($xl2,$xt2,$xr2,$xb2) = $parts[-1]->bounds; 1144 if ($x2 > $xr2) { 1145 $self->_connector($gd,$dx,$dy,$parts[-1]->bounds,$x2,$xt2,$x2,$xb2); 1146 } 1147 } else { 1148 # This code draws the connectors from end-to-end when there are no parts in 1149 # view (e.g. zoomed into a gap in an alignment). 1150 my ($x1,$y1,$x2,$y2) = $self->bounds($dx,$dy); 1151 $self->draw_connector($gd,$y1,$y2,$x1,$y1,$y2,$x2); 1152 } 1153 1154} 1155 1156# return true if this feature should be highlited 1157sub hilite_color { 1158 my $self = shift; 1159 return if $self->level>0; # only highlite top level glyphs 1160 my $index = $self->option('hilite') or return; 1161 $self->factory->translate_color($index); 1162} 1163 1164sub draw_highlight { 1165 my $self = shift; 1166 my ($gd,$left,$top) = @_; 1167 my $color = $self->hilite_color or return; 1168 my @bounds = $self->bounds; 1169 $gd->filledRectangle($bounds[0]+$left - 3, 1170 $bounds[1]+$top - 3, 1171 $bounds[2]+$left + 3, 1172 $bounds[3]+$top + 3, 1173 $color); 1174} 1175 1176sub _connector { 1177 my $self = shift; 1178 my ($gd, 1179 $dx,$dy, 1180 $xl,$xt,$xr,$xb, 1181 $yl,$yt,$yr,$yb) = @_; 1182 my $left = $dx + $xr; 1183 my $right = $dx + $yl; 1184 my $top1 = $dy + $xt; 1185 my $bottom1 = $dy + $xb; 1186 my $top2 = $dy + $yt; 1187 my $bottom2 = $dy + $yb; 1188 1189 # restore this comment if you don't like the group dash working 1190 # its way backwards. 1191 return if $right-$left < 1 && !$self->isa('Bio::Graphics::Glyph::group'); 1192 1193 $self->draw_connector($gd, 1194 $top1,$bottom1,$left, 1195 $top2,$bottom2,$right, 1196 ); 1197} 1198 1199sub draw_connector { 1200 my $self = shift; 1201 my $gd = shift; 1202 my $color = $self->connector_color; 1203 my $connector_type = $self->connector or return; 1204 1205 if ($connector_type eq 'hat') { 1206 $self->draw_hat_connector($gd,$color,@_); 1207 } elsif ($connector_type eq 'solid') { 1208 $self->draw_solid_connector($gd,$color,@_); 1209 } elsif ($connector_type eq 'dashed') { 1210 $self->draw_dashed_connector($gd,$color,@_); 1211 } elsif ($connector_type eq 'quill') { 1212 $self->draw_quill_connector($gd,$color,@_); 1213 } elsif ($connector_type eq 'crossed') { 1214 $self->draw_crossed_connector($gd,$color,@_); 1215 } else { 1216 ; # draw nothing 1217 } 1218} 1219 1220sub draw_hat_connector { 1221 my $self = shift; 1222 my $gd = shift; 1223 my $color = shift; 1224 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_; 1225 1226 cluck "gd object is $gd" unless ref $gd; 1227 1228 my $center1 = ($top1 + $bottom1)/2; 1229 my $quarter1 = $top1 + ($bottom1-$top1)/4; 1230 my $center2 = ($top2 + $bottom2)/2; 1231 my $quarter2 = $top2 + ($bottom2-$top2)/4; 1232 1233 if ($center1 != $center2) { 1234 $self->draw_solid_connector($gd,$color,@_); 1235 return; 1236 } 1237 1238 if ($right - $left > 4) { # room for the inverted "V" 1239 my $middle = $left + int(($right - $left)/2); 1240 $gd->line($left,$center1,$middle,$top1,$color); 1241 $gd->line($middle,$top1,$right-1,$center1,$color); 1242 } elsif ($right-$left > 1) { # no room, just connect 1243 $gd->line($left,$quarter1,$right-1,$quarter1,$color); 1244 } 1245 1246} 1247 1248sub draw_solid_connector { 1249 my $self = shift; 1250 my $gd = shift; 1251 my $color = shift; 1252 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_; 1253 1254 my $center1 = ($top1 + $bottom1)/2; 1255 my $center2 = ($top2 + $bottom2)/2; 1256 1257 $gd->line($left,$center1,$right,$center2,$color); 1258} 1259 1260sub draw_dashed_connector { 1261 my $self = shift; 1262 my $gd = shift; 1263 my $color = shift; 1264 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_; 1265 1266 my $center1 = ($top1 + $bottom1)/2; 1267 my $center2 = ($top2 + $bottom2)/2; 1268 my $image_class = $self->panel->image_class; 1269 my $gdTransparent = $image_class->gdTransparent; 1270 my $gdStyled = $image_class->gdStyled; 1271 $gd->setStyle($color,$color,$gdTransparent,$gdTransparent); 1272 $gd->line($left,$center1,$right,$center2,$gdStyled); 1273} 1274 1275sub draw_quill_connector { 1276 my $self = shift; 1277 my $gd = shift; 1278 my $color = shift; 1279 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_; 1280 1281 my $center1 = ($top1 + $bottom1)/2; 1282 my $center2 = ($top2 + $bottom2)/2; 1283 1284 $gd->line($left,$center1,$right,$center2,$color); 1285 my $direction = $self->feature->strand; 1286 return unless $direction; 1287 $direction *= -1 if $self->{flip}; 1288 1289 if ($direction > 0) { 1290 my $start = $left+4; 1291 my $end = $right-1; 1292 for (my $position=$start; $position <= $end; $position += QUILL_INTERVAL) { 1293 $gd->line($position,$center1,$position-2,$center1-2,$color); 1294 $gd->line($position,$center1,$position-2,$center1+2,$color); 1295 } 1296 } else { 1297 my $start = $left+1; 1298 my $end = $right-4; 1299 for (my $position=$start; $position <= $end; $position += QUILL_INTERVAL) { 1300 $gd->line($position,$center1,$position+2,$center1-2,$color); 1301 $gd->line($position,$center1,$position+2,$center1+2,$color); 1302 } 1303 } 1304} 1305 1306sub draw_crossed_connector { 1307 my $self = shift; 1308 my $gd = shift; 1309 my $color = shift; 1310 my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_; 1311 1312 #Draw the horizontal line 1313 my $center1 = ($top1 + $bottom1)/2; 1314 my $center2 = ($top2 + $bottom2)/2; 1315 1316 $gd->line($left,$center1,$right,$center2,$color); 1317 1318 #Extra validations 1319 ($left, $right) = ($right, $left) if ($right < $left); 1320 ($top1, $bottom1) = ($bottom1, $top1) if ($bottom1 < $top1); 1321 ($top2, $bottom2) = ($bottom2, $top2) if ($bottom2 < $top2); 1322 1323 #Draw the "X" 1324 my $middle = int(($right - $left) / 2) + $left; 1325 my $midLen = int(($bottom1 - $top1) / 2); 1326 1327 $gd->line($middle-$midLen,$top1, $middle+$midLen,$bottom2,$color); 1328 $gd->line($middle-$midLen,$bottom1,$middle+$midLen,$top2,$color); 1329} 1330 1331sub filled_box { 1332 my $self = shift; 1333 my $gd = shift; 1334 my ($x1,$y1,$x2,$y2,$bg,$fg,$lw) = @_; 1335 1336 $bg ||= $self->bgcolor; 1337 $fg ||= $self->fgcolor; 1338 $lw ||= $self->option('linewidth') || 1; 1339 $x2 = $x1+1 if abs($x2-$x1) < 1; 1340 1341 $gd->filledRectangle($x1,$y1,$x2,$y2,$bg); 1342 $fg = $self->set_pen($lw,$fg) if $lw > 1; 1343 1344 # draw a box 1345 $gd->rectangle($x1,$y1,$x2,$y2,$fg); 1346 1347 # if the left end is off the end, then cover over 1348 # the leftmost line 1349 $self->blunt($gd,$x1,$y1,$x2,$y2,$bg,$fg,$lw); 1350} 1351 1352sub blunt { 1353 my $self = shift; 1354 my $gd = shift; 1355 my ($x1,$y1,$x2,$y2,$bg,$fg,$lw) = @_; 1356 1357 # if the left end is off the end, then cover over 1358 # the leftmost line 1359 my ($width) = $gd->getBounds; 1360 1361 $bg = $self->set_pen($lw,$bg) if $lw > 1; 1362 1363 $gd->line($x1,$y1+$lw,$x1,$y2-$lw,$bg) 1364 if $x1 < $self->panel->pad_left; 1365 1366 $gd->line($x2,$y1+$lw,$x2,$y2-$lw,$bg) 1367 if $x2 > $width - $self->panel->pad_right; 1368} 1369 1370sub filled_oval { 1371 my $self = shift; 1372 my $gd = shift; 1373 my ($x1,$y1,$x2,$y2,$bg,$fg,$lw) = @_; 1374 my $cx = ($x1+$x2)/2; 1375 my $cy = ($y1+$y2)/2; 1376 1377 $fg ||= $self->fgcolor; 1378 $bg ||= $self->bgcolor; 1379 $lw ||= $self->linewidth; 1380 1381 $fg = $self->set_pen($lw) if $lw > 1; 1382 1383 # Maintain backwards compatability with gd 1.8.4 1384 # which does not support the ellipse methods. 1385 # can() method fails with GD::SVG... 1386 if ($gd->can('ellipse') || $gd =~ /SVG/ ) { 1387 $gd->filledEllipse($cx,$cy,$x2-$x1,$y2-$y1,$bg); 1388 # Draw the edge around the ellipse 1389 $gd->ellipse($cx,$cy,$x2-$x1,$y2-$y1,$fg); 1390 } else { 1391 $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg); 1392 $gd->fillToBorder($cx,$cy,$fg,$bg); 1393 } 1394} 1395 1396sub oval { 1397 my $self = shift; 1398 my $gd = shift; 1399 my ($x1,$y1,$x2,$y2) = @_; 1400 my $cx = ($x1+$x2)/2; 1401 my $cy = ($y1+$y2)/2; 1402 1403 my $fg = $self->fgcolor; 1404 my $linewidth = $self->linewidth; 1405 $fg = $self->set_pen($linewidth) if $linewidth > 1; 1406 1407 # Maintain backwards compatability with gd 1.8.4 which does not 1408 # support the ellipse method. 1409 if ($gd->can('ellipse') || $gd =~ /SVG/ ) { 1410 $gd->ellipse($cx,$cy,$x2-$x1,$y2-$y1,$fg); 1411 } else { 1412 $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg); 1413 } 1414} 1415 1416sub filled_arrow { 1417 my $self = shift; 1418 my $gd = shift; 1419 my $orientation = shift; 1420 my ($x1,$y1,$x2,$y2,$fg,$bg,$force) = @_; 1421 1422 $orientation *= -1 if $self->{flip}; 1423 1424 my ($width) = $gd->getBounds; 1425 my $indent = $y2-$y1 < $x2-$x1 ? $y2-$y1 : ($x2-$x1)/2; 1426 1427 my $panel = $self->panel; 1428 my $offend_left = $x1 < $panel->pad_left; 1429 my $offend_right = $x2 > $panel->width + $panel->pad_left; 1430 1431 return $self->filled_box($gd,@_) 1432 if !$force && 1433 (($orientation == 0) 1434 or ($x1 < 0 && $orientation < 0) 1435 or ($x2 > $width && $orientation > 0) 1436 or ($indent <= 0) 1437 or ($x2 - $x1 < 3) 1438 or ($offend_left && $orientation < 0) 1439 or ($offend_right && $orientation > 0)); 1440 1441 $fg ||= $self->fgcolor; 1442 $bg ||= $self->bgcolor; 1443 1444 my $lw = $self->option('linewidth') || 1; 1445 $fg = $self->set_pen($lw,$fg) if $lw > 1; 1446 1447 my $pkg = $self->polygon_package; 1448 my $poly = $pkg->new(); 1449 if ($orientation >= 0) { 1450 $poly->addPt($x1,$y1); 1451 $poly->addPt($x2-$indent,$y1); 1452 $poly->addPt($x2,($y2+$y1)/2); 1453 $poly->addPt($x2-$indent,$y2); 1454 $poly->addPt($x1,$y2); 1455 } else { 1456 $poly->addPt($x2,$y1); 1457 $poly->addPt($x2,$y2); 1458 $poly->addPt($x1+$indent,$y2); 1459 $poly->addPt($x1,($y2+$y1)/2); 1460 $poly->addPt($x1+$indent,$y1); 1461 } 1462 $gd->filledPolygon($poly,$bg); 1463 $gd->polygon($poly,$fg); 1464 1465 # blunt it a bit if off the end 1466 1467 $self->blunt($gd,$x1,$y1,$x2,$y2,$bg,$fg,$lw) if 1468 ($offend_left && $orientation > 0) 1469 or ($offend_right && $orientation < 0); 1470} 1471 1472sub linewidth { 1473 shift->option('linewidth') || 1; 1474} 1475 1476sub font_width { 1477 my $self = shift; 1478 my $font = shift; 1479 $self->panel->string_width($font||$self->font,'m'); 1480} 1481 1482sub font_height { 1483 my $self = shift; 1484 my $font = shift; 1485 $self->panel->string_height($font||$self->font,'hj'); 1486} 1487 1488sub string_width { 1489 my $self = shift; 1490 my ($string,$font) = @_; 1491 $self->panel->string_width($font||$self->font,$string||'m'); 1492} 1493 1494sub string_height { 1495 my $self = shift; 1496 my ($string,$font) = @_; 1497 $self->panel->string_height($font||$self->font,$string||'hj'); 1498} 1499 1500sub fill { 1501 my $self = shift; 1502 my $gd = shift; 1503 my ($x1,$y1,$x2,$y2) = @_; 1504 if ( ($x2-$x1) >= 2 && ($y2-$y1) >= 2 ) { 1505 $gd->fill($x1+1,$y1+1,$self->bgcolor); 1506 } 1507} 1508sub set_pen { 1509 my $self = shift; 1510 my ($linewidth,$color) = @_; 1511 $linewidth ||= $self->linewidth; 1512 $color ||= $self->fgcolor; 1513 return $color unless $linewidth > 1; 1514 $self->panel->set_pen($linewidth,$color); 1515} 1516 1517sub draw_component { 1518 my $self = shift; 1519 my ($gd,$left,$top,$partno,$total_parts) = @_; 1520 my($x1,$y1,$x2,$y2) = $self->bounds($left,$top); 1521 1522 # clipping 1523 my $panel = $self->panel; 1524 return unless $x2 >= $panel->left and $x1 <= $panel->right; 1525 1526 if ($self->stranded) { 1527 $self->filled_arrow($gd, 1528 $self->feature->strand, 1529 $x1, $y1, 1530 $x2, $y2) 1531 } else { 1532 $self->filled_box($gd, 1533 $x1, $y1, 1534 $x2, $y2) 1535 } 1536} 1537 1538sub show_strand { 1539 my $self = shift; 1540 my $s = $self->option('strand_arrow'); 1541 return $s if defined $s; 1542 return $self->option('stranded'); 1543} 1544sub stranded { 1545 my $self = shift; 1546 my $s = $self->show_strand; 1547 return unless $s; 1548 return 1 unless $s eq 'ends'; 1549 1550 my $f = $self->feature; 1551 my $strand = $f->strand; 1552 $strand *= -1 if $self->{flip}; 1553 my $part_no = $self->{partno}; 1554 my $parts = $self->{total_parts}; 1555 return ($strand > 0 && $part_no == $parts-1) 1556 || ($strand < 0 && $part_no == 0); 1557} 1558 1559 1560sub no_subparts { 1561 return shift->option('no_subparts'); 1562} 1563 1564sub maxdepth { 1565 my $self = shift; 1566 1567 my $maxdepth = $self->option('maxdepth'); 1568 return $maxdepth if defined $maxdepth; 1569 1570 # $feature->compound is an artefact from aggregators. Sadly, an aggregated feature can miss 1571 # parts that are out of the query range - this is a horrible mis-feature. Aggregated features have 1572 # a compound flag to hack around this. 1573 my $feature = $self->feature; 1574 return 1 if $feature->can('compound') && $feature->compound; 1575 1576 return; 1577} 1578 1579sub feature_limit { 1580 return shift->option('feature_limit') || 0; 1581} 1582 1583sub exceeds_depth { 1584 my $self = shift; 1585 my $max_depth = $self->maxdepth; 1586 return unless defined $max_depth; 1587 1588 my $current_depth = $self->level || 0; 1589 return $current_depth >= $max_depth; 1590} 1591 1592# memoize _subfeat -- it's a bottleneck with segments 1593sub subfeat { 1594 my $self = shift; 1595 my $feature = shift; 1596 1597 return $self->_subfeat($feature) unless ref $self; # protect against class invocation 1598 1599 return if $self->level == 0 && $self->no_subparts; 1600 return if $self->exceeds_depth; 1601 1602 return @{$self->{cached_subfeat}{$feature}} if exists $self->{cached_subfeat}{$feature}; 1603 my @ss = $self->_subfeat($feature); 1604 $self->{cached_subfeat}{$feature} = \@ss; 1605 @ss; 1606} 1607 1608sub _subfeat { 1609 my $class = shift; 1610 my $feature = shift; 1611 1612 return $feature->segments if $feature->can('segments'); 1613 1614 my @split = eval { my $id = $feature->location->seq_id; 1615 my @subs = $feature->location->sub_Location; 1616 grep {$id eq $_->seq_id} @subs; 1617 }; 1618 1619 return @split if @split; 1620 1621 # Either the APIs have changed, or I got confused at some point... 1622 return $feature->get_SeqFeatures if $feature->can('get_SeqFeatures'); 1623 return $feature->sub_SeqFeature if $feature->can('sub_SeqFeature'); 1624 return; 1625} 1626 1627# synthesize a key glyph 1628sub keyglyph { 1629 my $self = shift; 1630 my $feature = $self->make_key_feature; 1631 my $factory = $self->factory->clone; 1632 $factory->set_option(label => 1); 1633 $factory->set_option(description => 0); 1634 $factory->set_option(bump => 0); 1635 $factory->set_option(connector => 'solid'); 1636 return $factory->make_glyph(0,$feature); 1637} 1638 1639# synthesize a key glyph 1640sub make_key_feature { 1641 my $self = shift; 1642 1643 my $scale = 1/$self->scale; # base pairs/pixel 1644 1645 # one segments, at pixels 0->80 1646 my $offset = $self->panel->offset; 1647 1648 my $feature = 1649 Bio::Graphics::Feature->new(-start =>0 * $scale +$offset, 1650 -end =>80*$scale+$offset, 1651 -name => $self->make_key_name(), 1652 -strand => '+1'); 1653 return $feature; 1654} 1655 1656sub make_key_name { 1657 my $self = shift; 1658 1659 # breaking encapsulation - this should be handled by the panel 1660 my $key = $self->option('key') || ''; 1661 return $key unless $self->panel->add_category_labels; 1662 1663 my $category = $self->option('category'); 1664 my $name = defined $category ? "$key ($category)" : $key; 1665 return $name; 1666} 1667 1668sub all_callbacks { 1669 my $self = shift; 1670 return $self->{all_callbacks} if exists $self->{all_callbacks}; # memoize 1671 return $self->{all_callbacks} = $self->_all_callbacks; 1672} 1673 1674sub _all_callbacks { 1675 my $self = shift; 1676 my $track_level = $self->option('all_callbacks'); 1677 return $track_level if defined $track_level; 1678 return $self->panel->all_callbacks; 1679} 1680 1681sub subpart_callbacks { 1682 my $self = shift; 1683 return $self->{subpart_callbacks} if exists $self->{subpart_callbacks}; # memoize 1684 return $self->{subpart_callbacks} = $self->_subpart_callbacks; 1685} 1686 1687sub _subpart_callbacks { 1688 my $self = shift; 1689 return 1 if $self->all_callbacks; 1690 my $do_subparts = $self->option('subpart_callbacks'); 1691 return $self->{level} == 0 || ($self->{level} > 0 && $do_subparts); 1692} 1693 1694sub default_factory { 1695 croak "no default factory implemented"; 1696} 1697 1698sub finished { 1699 my $self = shift; 1700 delete $self->{factory}; 1701 foreach (@{$self->{parts} || []}) { 1702 $_->finished; 1703 } 1704 delete $self->{parts}; 1705} 1706 1707 1708############################################################ 1709# autogeneration of options documentation 1710############################################################ 1711 1712sub options { 1713 my $self = shift; 1714 my $seenit = shift || {}; 1715 no strict 'refs'; 1716 my $class = ref $self || $self; 1717 my $isa = "$class\:\:ISA"; 1718 1719 $seenit->{$class}++; 1720 my $options = $self->my_options 1721 if defined &{"$class\:\:my_options"}; 1722 1723 my @inherited_options; 1724 1725 for my $base (@$isa) { 1726 next if $seenit->{$base}++; 1727 $base->can('options') or next; 1728 my $o = $base->options($seenit); 1729 push @inherited_options,%$o; 1730 } 1731 return wantarray ? ($options,{@inherited_options}) 1732 : {@inherited_options,%$options}; 1733} 1734 1735 1736sub options_usage { 1737 my $self = shift; 1738 my ($read,$write); 1739 pipe($read,$write); 1740 my $child = fork(); 1741 unless ($child) { 1742 close $read; 1743 print $write $self->options_pod; 1744 exit 0; 1745 } 1746 close $write; 1747 eval "use Pod::Usage"; 1748 pod2usage({-input =>$read, 1749 -verbose=>2, 1750 }); 1751} 1752 1753sub options_man { 1754 my $self = shift; 1755 my $nroff; 1756 chomp($nroff = `which nroff`) if $ENV{SHELL}; 1757 unless ($nroff) { 1758 $self->options_usage; 1759 return; 1760 } 1761 my $class = ref $self || $self; 1762 my $extra = ''; 1763 1764 if ($ENV{TERM} && $ENV{TERM}=~/^(xterm|vt10)/) { 1765 my ($pager) = grep {`which $_`} ($ENV{PAGER},'less','more'); 1766 $extra = "|$pager"; 1767 } 1768 open my $fh,"| pod2man -n $class | $nroff -man $extra" or die; 1769 print $fh $self->options_pod; 1770 close $fh; 1771 # exit 0 ?? 1772} 1773 1774sub options_pod { 1775 my $self = shift; 1776 my ($new_options,$old_options) = $self->options; 1777 1778 my $class = ref $self || $self; 1779 my ($glyph_name) = $class =~ /([^:]+)$/; 1780 1781 my $description = join "\n",$self->my_description; 1782 1783 my $pod = ''; 1784 $pod .= "=head1 NAME\n\n"; 1785 $pod .= <<END; 1786 1787The B<$glyph_name> glyph. 1788 1789END 1790; 1791 $pod .= "=head1 SYNOPSIS\n\n"; 1792 $pod .= <<"END"; 1793$description 1794See the L<Bio\:\:Graphics\:\:Glyph\:\:$glyph_name> manual page 1795for full details. 1796 1797 \$panel->add_track(\$features, 1798 -glyph => $glyph_name, 1799 -option1 => \$value1, 1800 -option2 => \$value2...); 1801 1802To experiment with this glyph\'s options, use the glyph_help.pl 1803script with either the -v or -p switch. Run "glyph_help -help" for details. 1804 1805END 1806 ; 1807 $pod .= "=head1 OPTIONS DEFINED IN THIS GLYPH\n\n"; 1808 $pod .= "Glyph-specific options for the I<$glyph_name> glyph:\n\n"; 1809 $pod .= "=over 4\n\n"; 1810 $pod .= $self->_pod_options($new_options || {}); 1811 $pod .= "=back\n\n"; 1812 1813 $pod .= "=head1 INHERITED OPTIONS\n\n"; 1814 $pod .= "Options inherited from more general glyph classes:\n\n"; 1815 $pod .= "=over 4\n\n"; 1816 $pod .= $self->_pod_options($old_options || {}); 1817 $pod .= "=back\n\n"; 1818 1819 $pod .= "=head1 COLOR OPTIONS\n\n"; 1820 $pod .= "The following list of named colors can be used as an argument to any option "; 1821 $pod .= "that takes a color:\n\n"; 1822 eval "require Bio::Graphics::Panel" unless Bio::Graphics::Panel->can('color_names'); 1823 for my $c (sort Bio::Graphics::Panel->color_names) { 1824 $pod .= " $c\n"; 1825 } 1826 $pod; 1827} 1828 1829sub _pod_options { 1830 my $self = shift; 1831 my $options = shift; 1832 1833 my $pod = %$options ? '' : "B<(none)>\n\n"; 1834 for my $option (sort keys %$options) { 1835 my ($range,$default,@description) = @{$options->{$option}}; 1836 $default = $range eq 'boolean' ? "'undef' (false)" 1837 : "'undef'" 1838 unless defined $default; 1839 $default = "1 (true)" if $range eq 'boolean' && $default == 1; 1840 $range = join ', ',map {"'$_'"} @$range if ref $range eq 'ARRAY'; 1841 $pod .= "=item B<-$option> <$range> [default $default]\n\n"; 1842 $pod .= join "\n",@description; 1843 if ($range eq 'font') { 1844 $pod .= "\nValid choices: 'gdTinyFont', 'gdSmallFont', 'gdMediumBoldFont', 'gdLargeFont', 'gdGiantFont'"; 1845 } elsif ($range eq 'color') { 1846 $pod .= "\nSee next section for color choices.\n"; 1847 } 1848 1849 $pod .= "\n\n"; 1850 } 1851 return $pod; 1852} 1853 1854# normalizer for memoize 1855sub _normalize_objects { 1856 my ($obj,$option_name) = @_; 1857 my @args = (%$obj,$option_name); 1858 return "@args"; 1859} 1860 18611; 1862 1863__END__ 1864 1865=head1 NAME 1866 1867Bio::Graphics::Glyph - Base class for Bio::Graphics::Glyph objects 1868 1869=head1 SYNOPSIS 1870 1871See L<Bio::Graphics::Panel>. 1872 1873=head1 DESCRIPTION 1874 1875Bio::Graphics::Glyph is the base class for all glyph objects. Each 1876glyph is a wrapper around an Bio:SeqFeatureI object, knows how to 1877render itself on an Bio::Graphics::Panel, and has a variety of 1878configuration variables. 1879 1880End developers will not ordinarily work directly with 1881Bio::Graphics::Glyph objects, but with Bio::Graphics::Glyph::generic 1882and its subclasses. Similarly, most glyph developers will want to 1883subclass from Bio::Graphics::Glyph::generic because the latter 1884provides labeling and arrow-drawing facilities. 1885 1886=head1 METHODS 1887 1888This section describes the class and object methods for 1889Bio::Graphics::Glyph. 1890 1891=head2 CONSTRUCTORS 1892 1893Bio::Graphics::Glyph objects are constructed automatically by an 1894Bio::Graphics::Glyph::Factory, and are not usually created by 1895end-developer code. 1896 1897=over 4 1898 1899=item $glyph = Bio::Graphics::Glyph-E<gt>new(-feature=E<gt>$feature,-factory=E<gt>$factory) 1900 1901Given a sequence feature, creates an Bio::Graphics::Glyph object to 1902display it. The B<-feature> argument points to the Bio:SeqFeatureI 1903object to display, and B<-factory> indicates an 1904Bio::Graphics::Glyph::Factory object from which the glyph will fetch 1905all its run-time configuration information. Factories are created and 1906manipulated by the Bio::Graphics::Panel object. 1907 1908A standard set of options are recognized. See L<OPTIONS>. 1909 1910=back 1911 1912=head2 OBJECT METHODS 1913 1914Once a glyph is created, it responds to a large number of methods. In 1915this section, these methods are grouped into related categories. 1916 1917Retrieving glyph context: 1918 1919=over 4 1920 1921=item $factory = $glyph-E<gt>factory 1922 1923Get the Bio::Graphics::Glyph::Factory associated with this object. 1924This cannot be changed once it is set. 1925 1926=item $panel = $glyph-E<gt>panel 1927 1928Get the Bio::Graphics::Panel associated with this object. This cannot 1929be changed once it is set. 1930 1931=item $feature = $glyph-E<gt>feature 1932 1933Get the sequence feature associated with this object. This cannot be 1934changed once it is set. 1935 1936=item $feature = $glyph-E<gt>parent_feature() 1937 1938Within callbacks only, the parent_feature() method returns the parent 1939of the current feature, if there is one. Called with a numeric 1940argument, ascends the parentage tree: parent_feature(1) will return 1941the parent, parent_feature(2) will return the grandparent, etc. If 1942there is no parent, returns undef. 1943 1944=item $feature = $glyph-E<gt>add_feature(@features) 1945 1946Add the list of features to the glyph, creating subparts. This is 1947most common done with the track glyph returned by 1948Bio::Graphics::Panel-E<gt>add_track(). 1949 1950If the Bio::Graphics::Panel was initialized with B<-feature_limit> set 1951to a non-zero value, then calls to a track glyph's add_feature() 1952method will maintain a count of features added to the track. Once the 1953feature count exceeds the value set in -feature_limit, additional 1954features will displace existing ones in a way that effects a uniform 1955sampling of the total feature set. This is useful to protect against 1956excessively large tracks. The total number of features added can be 1957retrieved by calling the glyph's feature_count() method. 1958 1959=item $feature = $glyph-E<gt>add_group(@features) 1960 1961This is similar to add_feature(), but the list of features is treated 1962as a group and can be configured as a set. 1963 1964=item $glyph-E<gt>finished 1965 1966When you are finished with a glyph, you can call its finished() method 1967in order to break cycles that would otherwise cause memory leaks. 1968finished() is typically only used by the Panel object. 1969 1970=item $subglyph = $glyph-E<gt>make_subglyph($level,@sub_features) 1971 1972This method is called to create subglyphs from a list of 1973subfeatures. The $level indicates the current level of the glyph 1974(top-level glyphs are level 0, subglyphs are level 1, etc). 1975 1976Ordinarily this method simply calls 1977$self-E<gt>factory-E<gt>make_subglyph($level,@sub_features). Override 1978it in subclasses to create subglyphs of a particular type. For 1979example: 1980 1981 sub make_subglyph { 1982 my $self = shift; 1983 my $level = shift; 1984 my $factory = $self->factory; 1985 $factory->make_glyph($factory,'arrow',@_); 1986 } 1987 1988=item $count = $glyph-E<gt>feature_count() 1989 1990Return the number of features added to this glyph via add_feature(). 1991 1992=item $flag = $glyph->features_clipped() 1993 1994If the panel was initialized with -feature_limit set to a non-zero 1995value, then calls to add_features() will limit the number of glyphs to 1996the indicated value. If this value was exceeded, then 1997features_clipped() will return true. 1998 1999=back 2000 2001Retrieving glyph options: 2002 2003=over 4 2004 2005=item $fgcolor = $glyph-E<gt>fgcolor 2006 2007=item $bgcolor = $glyph-E<gt>bgcolor 2008 2009=item $fontcolor = $glyph-E<gt>fontcolor 2010 2011=item $fontcolor = $glyph-E<gt>font2color 2012 2013=item $fillcolor = $glyph-E<gt>fillcolor 2014 2015These methods return the configured foreground, background, font, 2016alternative font, and fill colors for the glyph in the form of a 2017GD::Image color index. 2018 2019=item $color = $glyph-E<gt>tkcolor 2020 2021This method returns a color to be used to flood-fill the entire glyph 2022before drawing (currently used by the "track" glyph). 2023 2024=item ($left,$top,$right,$bottom) = $glyph-E<gt>bounds($dx,$dy) 2025 2026Given the topleft coordinates of the glyph, return the bounding box of 2027its contents, exclusive of padding. This is typically called by the 2028draw() and draw_component() methods to recover the position of the 2029glyph. 2030 2031=item ($left,$top,$right,$bottom) = $glyph-E<gt>calculate_boundaries($dx,$dy) 2032 2033An alias for bounds(), used by some glyphs for compatibility with older versions of this module. 2034 2035=item $width = $glyph-E<gt>width([$newwidth]) 2036 2037Return the width of the glyph, not including left or right padding. 2038This is ordinarily set internally based on the size of the feature and 2039the scale of the panel. 2040 2041=item $width = $glyph-E<gt>layout_width 2042 2043Returns the width of the glyph including left and right padding. 2044 2045=item $width = $glyph-E<gt>height 2046 2047Returns the height of the glyph, not including the top or bottom 2048padding. This is calculated from the "height" option and cannot be 2049changed. 2050 2051=item $font = $glyph-E<gt>font 2052 2053Return the font for the glyph. 2054 2055=item $option = $glyph-E<gt>option($option) 2056 2057Return the value of the indicated option. 2058 2059=item $index = $glyph-E<gt>color($option_name) 2060 2061Given an option name that corresponds to a color (e.g. 'fgcolor') look 2062up the option and translate it into a GD color index. 2063 2064=item $index = $glyph-E<gt>translate_color($color) 2065 2066Given a symbolic or #RRGGBB-form color name, returns its GD index. 2067 2068=item $level = $glyph-E<gt>level 2069 2070The "level" is the nesting level of the glyph. 2071Groups are level -1, top level glyphs are level 0, 2072subparts (e.g. exons) are level 1 and so forth. 2073 2074=item @parts = $glyph-E<gt>parts 2075 2076For glyphs that can contain subparts (e.g. the segments glyph), this 2077method will return the list of subglyphs it contains. Subglyphs are 2078created automatically by the new() method and are created subject to 2079the maximum recursion depth specified by the maxdepth() method and/or 2080the -maxdepth option. 2081 2082 2083=back 2084 2085Setting an option: 2086 2087=over 4 2088 2089=item $glyph-E<gt>configure(-name=E<gt>$value) 2090 2091You may change a glyph option after it is created using set_option(). 2092This is most commonly used to configure track glyphs. 2093 2094=back 2095 2096Retrieving information about the sequence: 2097 2098=over 4 2099 2100=item $start = $glyph-E<gt>start 2101 2102=item $end = $glyph-E<gt>end 2103 2104These methods return the start and end of the glyph in base pair 2105units. 2106 2107=item $offset = $glyph-E<gt>offset 2108 2109Returns the offset of the segment (the base pair at the far left of 2110the image). 2111 2112=item $length = $glyph-E<gt>length 2113 2114Returns the length of the sequence segment. 2115 2116=back 2117 2118 2119Retrieving formatting information: 2120 2121=over 4 2122 2123=item $top = $glyph-E<gt>top 2124 2125=item $left = $glyph-E<gt>left 2126 2127=item $bottom = $glyph-E<gt>bottom 2128 2129=item $right = $glyph-E<gt>right 2130 2131These methods return the top, left, bottom and right of the glyph in 2132pixel coordinates. 2133 2134=item $height = $glyph-E<gt>height 2135 2136Returns the height of the glyph. This may be somewhat larger or 2137smaller than the height suggested by the GlyphFactory, depending on 2138the type of the glyph. 2139 2140=item $scale = $glyph-E<gt>scale 2141 2142Get the scale for the glyph in pixels/bp. 2143 2144=item $height = $glyph-E<gt>labelheight 2145 2146Return the height of the label, if any. 2147 2148=item $label = $glyph-E<gt>label 2149 2150Return a human-readable label for the glyph. 2151 2152=back 2153 2154These methods are called by Bio::Graphics::Track during the layout 2155process: 2156 2157=over 4 2158 2159=item $glyph-E<gt>move($dx,$dy) 2160 2161Move the glyph in pixel coordinates by the indicated delta-x and 2162delta-y values. 2163 2164=item ($x1,$y1,$x2,$y2) = $glyph-E<gt>box 2165 2166Return the current position of the glyph. 2167 2168=back 2169 2170These methods are intended to be overridden in subclasses: 2171 2172=over 4 2173 2174=item $glyph-E<gt>calculate_height 2175 2176Calculate the height of the glyph. 2177 2178=item $glyph-E<gt>calculate_left 2179 2180Calculate the left side of the glyph. 2181 2182=item $glyph-E<gt>calculate_right 2183 2184Calculate the right side of the glyph. 2185 2186=item $glyph-E<gt>draw($gd,$left,$top) 2187 2188Optionally offset the glyph by the indicated amount and draw it onto 2189the GD::Image object. 2190 2191=item $glyph-E<gt>draw_label($gd,$left,$top) 2192 2193Draw the label for the glyph onto the provided GD::Image object, 2194optionally offsetting by the amounts indicated in $left and $right. 2195 2196=item $glyph-E<gt>maxdepth() 2197 2198This returns the maximum number of levels of feature subparts that the 2199glyph will recurse through. For example, returning 0 indicates that 2200the glyph will only draw the top-level feature. Returning 1 indicates 2201that it will only draw the top-level feature and one level of 2202subfeatures. Returning 2 will descend down two levels. Overriding this 2203method will speed up rendering by avoiding creating of a bunch of 2204subglyphs that will never be drawn. 2205 2206The default behavior is to return undef (unlimited levels of descent) 2207unless the -maxdepth option is passed, in which case this number is 2208returned. 2209 2210Note that Bio::Graphics::Glyph::generic overrides maxdepth() to return 22110, meaning no descent into subparts will be performed. 2212 2213=back 2214 2215These methods are useful utility routines: 2216 2217=over 4 2218 2219=item @pixels = $glyph-E<gt>map_pt(@bases); 2220 2221Map the list of base position, given in base pair units, into pixels, 2222using the current scale and glyph position. This method will accept a 2223single base position or an array. 2224 2225=item $glyph-E<gt>filled_box($gd,$x1,$y1,$x2,$y2) 2226 2227Draw a filled rectangle with the appropriate foreground and fill 2228colors, and pen width onto the GD::Image object given by $gd, using 2229the provided rectangle coordinates. 2230 2231=item $glyph-E<gt>filled_oval($gd,$x1,$y1,$x2,$y2) 2232 2233As above, but draws an oval inscribed on the rectangle. 2234 2235=item $glyph-E<gt>exceeds_depth 2236 2237Returns true if descending into another level of subfeatures will 2238exceed the value returned by maxdepth(). 2239 2240=back 2241 2242=head2 OPTIONS 2243 2244The following options are standard among all Glyphs. See individual 2245glyph pages for more options. 2246 2247Also try out the glyph_help.pl script, which attempts to document each 2248glyph's shared and specific options and provides an interface for 2249graphically inspecting the effect of different options. 2250 2251 Option Description Default 2252 ------ ----------- ------- 2253 2254 -fgcolor Foreground color black 2255 2256 -bgcolor Background color turquoise 2257 2258 -fillcolor Synonym for -bgcolor 2259 2260 -linewidth Line width 1 2261 2262 -height Height of glyph 10 2263 2264 -font Glyph font gdSmallFont 2265 2266 -connector Connector type undef (false) 2267 2268 -connector_color 2269 Connector color black 2270 2271 -strand_arrow Whether to indicate undef (false) 2272 strandedness 2273 2274 -stranded Whether to indicate undef (false) 2275 strandedness 2276 (same as above)) 2277 2278 -label Whether to draw a label undef (false) 2279 2280 -description Whether to draw a description undef (false) 2281 2282 -no_subparts Set to true to prevent undef (false) 2283 drawing of the subparts 2284 of a feature. 2285 2286 -ignore_sub_part Give the types/methods of undef 2287 subparts to ignore (as a 2288 space delimited list). 2289 2290 -maxdepth Specifies the maximum number undef (unlimited) 2291 child-generations to decend 2292 when getting subfeatures 2293 2294 -sort_order Specify layout sort order "default" 2295 2296 -always_sort Sort even when bumping is off undef (false) 2297 2298 -bump_limit Maximum number of levels to bump undef (unlimited) 2299 2300 -hilite Highlight color undef (no color) 2301 2302 -link, -title, -target 2303 These options are used when creating imagemaps 2304 for display on the web. See L<Bio::Graphics::Panel/"Creating Imagemaps">. 2305 2306 2307For glyphs that consist of multiple segments, the B<-connector> option 2308controls what's drawn between the segments. The default is undef (no 2309connector). Options include: 2310 2311 "hat" an upward-angling conector 2312 "solid" a straight horizontal connector 2313 "quill" a decorated line with small arrows indicating strandedness 2314 (like the UCSC Genome Browser uses) 2315 "dashed" a horizontal dashed line. 2316 "crossed" a straight horizontal connector with an "X" on it 2317 (Can be used when segments are not yet validated 2318 by some internal experiments...) 2319 2320The B<-connector_color> option controls the color of the connector, if 2321any. 2322 2323The label is printed above the glyph. You may pass an anonymous 2324subroutine to B<-label>, in which case the subroutine will be invoked 2325with the feature as its single argument and is expected to return the 2326string to use as the label. If you provide the numeric value "1" to 2327B<-label>, the label will be read off the feature's seqname(), info() 2328and primary_tag() methods will be called until a suitable name is 2329found. To create a label with the text "1", pass the string "1 ". (A 23301 followed by a space). 2331 2332The description is printed below the glyph. You may pass an anonymous 2333subroutine to B<-description>, in which case the subroutine will be 2334invoked with the feature as its single argument and is expected to 2335return the string to use as the description. If you provide the 2336numeric value "1" to B<-description>, the description will be read off 2337the feature's source_tag() method. To create a description with the 2338text "1", pass the string "1 ". (A 1 followed by a space). 2339 2340In the case of ACEDB Ace::Sequence feature objects, the feature's 2341info(), Brief_identification() and Locus() methods will be called to 2342create a suitable description. 2343 2344The B<-strand_arrow> option, if true, requests that the glyph indicate 2345which strand it is on, usually by drawing an arrowhead. Not all 2346glyphs will respond to this request. For historical reasons, 2347B<-stranded> is a synonym for this option. Multisegmented features 2348will draw an arrowhead on each component unless you specify a value of 2349"ends" to -strand_arrow, in which case only the rightmost component 2350(for + strand features) or the leftmost component (for - strand 2351features) will have arrowheads. 2352 2353B<sort_order>: By default, features are drawn with a layout based only on the 2354position of the feature, assuring a maximal "packing" of the glyphs 2355when bumped. In some cases, however, it makes sense to display the 2356glyphs sorted by score or some other comparison, e.g. such that more 2357"important" features are nearer the top of the display, stacked above 2358less important features. The -sort_order option allows a few 2359different built-in values for changing the default sort order (which 2360is by "left" position): "low_score" (or "high_score") will cause 2361features to be sorted from lowest to highest score (or vice versa). 2362"left" (or "default") and "right" values will cause features to be 2363sorted by their position in the sequence. "longest" (or "shortest") 2364will cause the longest (or shortest) features to be sorted first, and 2365"strand" will cause the features to be sorted by strand: "+1" 2366(forward) then "0" (unknown, or NA) then "-1" (reverse). Finally, 2367"name" will sort by the display_name of the features. 2368 2369In all cases, the "left" position will be used to break any ties. To 2370break ties using another field, options may be strung together using a 2371"|" character; e.g. "strand|low_score|right" would cause the features 2372to be sorted first by strand, then score (lowest to highest), then by 2373"right" position in the sequence. 2374 2375Finally, a subroutine coderef with a $$ prototype can be provided. It 2376will receive two B<glyph> as arguments and should return -1, 0 or 1 2377(see Perl's sort() function for more information). For example, to 2378sort a set of database search hits by bits (stored in the features' 2379"score" fields), scaled by the log of the alignment length (with 2380"start" position breaking any ties): 2381 2382 sort_order = sub ($$) { 2383 my ($glyph1,$glyph2) = @_; 2384 my $a = $glyph1->feature; 2385 my $b = $glyph2->feature; 2386 ( $b->score/log($b->length) 2387 <=> 2388 $a->score/log($a->length) ) 2389 || 2390 ( $a->start <=> $b->start ) 2391 } 2392 2393It is important to remember to use the $$ prototype as shown in the 2394example. Otherwise Bio::Graphics will quit with an exception. The 2395arguments are subclasses of Bio::Graphics::Glyph, not the features 2396themselves. While glyphs implement some, but not all, of the feature 2397methods, to be safe call the two glyphs' feature() methods in order to 2398convert them into the actual features. 2399 2400The '-always_sort' option, if true, will sort features even if bumping 2401is turned off. This is useful if you would like overlapping features 2402to stack in a particular order. Features towards the end of the list 2403will overlay those towards the beginning of the sort order. 2404 2405The B<-hilite> option draws a colored box behind each feature using the 2406indicated color. Typically you will pass it a code ref that returns a 2407color name. For example: 2408 2409 -hilite => sub { my $name = shift->display_name; 2410 return 'yellow' if $name =~ /XYZ/ } 2411 2412The B<-no_subparts> option will prevent the glyph from searching its 2413feature for subfeatures. This may enhance performance if you know in 2414advance that none of your features contain subfeatures. 2415 2416=head1 SUBCLASSING Bio::Graphics::Glyph 2417 2418By convention, subclasses are all lower-case. Begin each subclass 2419with a preamble like this one: 2420 2421 package Bio::Graphics::Glyph::crossbox; 2422 2423 use strict; 2424 use base qw(Bio::Graphics::Glyph); 2425 2426Then override the methods you need to. Typically, just the draw() 2427method will need to be overridden. However, if you need additional 2428room in the glyph, you may override calculate_height(), 2429calculate_left() and calculate_right(). Do not directly override 2430height(), left() and right(), as their purpose is to cache the values 2431returned by their calculating cousins in order to avoid time-consuming 2432recalculation. 2433 2434A simple draw() method looks like this: 2435 2436 sub draw { 2437 my $self = shift; 2438 $self->SUPER::draw(@_); 2439 my $gd = shift; 2440 2441 # and draw a cross through the box 2442 my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); 2443 my $fg = $self->fgcolor; 2444 $gd->line($x1,$y1,$x2,$y2,$fg); 2445 $gd->line($x1,$y2,$x2,$y1,$fg); 2446 } 2447 2448This subclass draws a simple box with two lines criss-crossed through 2449it. We first call our inherited draw() method to generate the filled 2450box and label. We then call calculate_boundaries() to return the 2451coordinates of the glyph, disregarding any extra space taken by 2452labels. We call fgcolor() to return the desired foreground color, and 2453then call $gd-E<gt>line() twice to generate the criss-cross. 2454 2455For more complex draw() methods, see Bio::Graphics::Glyph::transcript 2456and Bio::Graphics::Glyph::segments. 2457 2458Please avoid using a specific image class (via "use GD" for example) 2459within your glyph package. Instead, rely on the image package passed 2460to the draw() method. This approach allows for future expansion of 2461supported image classes without requiring glyph redesign. If you need 2462access to the specific image classes such as Polygon, Image, or Font, 2463generate them like such: 2464 2465 sub draw { 2466 my $self = shift; 2467 my $image_class = shift; 2468 2469 my $polygon_package = $self->polygon_package->new() 2470 ... 2471 } 2472 2473=head1 BUGS 2474 2475Please report them. 2476 2477=head1 SEE ALSO 2478 2479L<Bio::DB::GFF::Feature>, 2480L<Ace::Sequence>, 2481L<Bio::Graphics::Panel>, 2482L<Bio::Graphics::Track>, 2483L<Bio::Graphics::Glyph::Factory>, 2484L<Bio::Graphics::Glyph::alignment>, 2485L<Bio::Graphics::Glyph::anchored_arrow>, 2486L<Bio::Graphics::Glyph::arrow>, 2487L<Bio::Graphics::Glyph::box>, 2488L<Bio::Graphics::Glyph::broken_line>, 2489L<Bio::Graphics::Glyph::cds>, 2490L<Bio::Graphics::Glyph::christmas_arrow>, 2491L<Bio::Graphics::Glyph::crossbox>, 2492L<Bio::Graphics::Glyph::dashed_line>, 2493L<Bio::Graphics::Glyph::diamond>, 2494L<Bio::Graphics::Glyph::dna>, 2495L<Bio::Graphics::Glyph::dot>, 2496L<Bio::Graphics::Glyph::dumbbell>, 2497L<Bio::Graphics::Glyph::ellipse>, 2498L<Bio::Graphics::Glyph::ex>, 2499L<Bio::Graphics::Glyph::extending_arrow>, 2500L<Bio::Graphics::Glyph::flag>, 2501L<Bio::Graphics::Glyph::gene>, 2502L<Bio::Graphics::Glyph::generic>, 2503L<Bio::Graphics::Glyph::graded_segments>, 2504L<Bio::Graphics::Glyph::group>, 2505L<Bio::Graphics::Glyph::heterogeneous_segments>, 2506L<Bio::Graphics::Glyph::image>, 2507L<Bio::Graphics::Glyph::lightning>, 2508L<Bio::Graphics::Glyph::line>, 2509L<Bio::Graphics::Glyph::merge_parts>, 2510L<Bio::Graphics::Glyph::merged_alignment>, 2511L<Bio::Graphics::Glyph::minmax>, 2512L<Bio::Graphics::Glyph::oval>, 2513L<Bio::Graphics::Glyph::pentagram>, 2514L<Bio::Graphics::Glyph::pinsertion>, 2515L<Bio::Graphics::Glyph::primers>, 2516L<Bio::Graphics::Glyph::processed_transcript>, 2517L<Bio::Graphics::Glyph::protein>, 2518L<Bio::Graphics::Glyph::ragged_ends>, 2519L<Bio::Graphics::Glyph::redgreen_box>, 2520L<Bio::Graphics::Glyph::redgreen_segment>, 2521L<Bio::Graphics::Glyph::repeating_shape>, 2522L<Bio::Graphics::Glyph::rndrect>, 2523L<Bio::Graphics::Glyph::ruler_arrow>, 2524L<Bio::Graphics::Glyph::saw_teeth>, 2525L<Bio::Graphics::Glyph::segmented_keyglyph>, 2526L<Bio::Graphics::Glyph::segments>, 2527L<Bio::Graphics::Glyph::so_transcript>, 2528L<Bio::Graphics::Glyph::span>, 2529L<Bio::Graphics::Glyph::splice_site>, 2530L<Bio::Graphics::Glyph::stackedplot>, 2531L<Bio::Graphics::Glyph::ternary_plot>, 2532L<Bio::Graphics::Glyph::text_in_box>, 2533L<Bio::Graphics::Glyph::three_letters>, 2534L<Bio::Graphics::Glyph::tic_tac_toe>, 2535L<Bio::Graphics::Glyph::toomany>, 2536L<Bio::Graphics::Glyph::track>, 2537L<Bio::Graphics::Glyph::transcript>, 2538L<Bio::Graphics::Glyph::transcript2>, 2539L<Bio::Graphics::Glyph::translation>, 2540L<Bio::Graphics::Glyph::triangle>, 2541L<Bio::Graphics::Glyph::two_bolts>, 2542L<Bio::Graphics::Glyph::wave>, 2543L<Bio::Graphics::Glyph::weighted_arrow>, 2544L<Bio::Graphics::Glyph::whiskerplot>, 2545L<Bio::Graphics::Glyph::xyplot> 2546 2547=head1 AUTHOR 2548 2549Lincoln Stein E<lt>lstein@cshl.orgE<gt> 2550 2551Copyright (c) 2001 Cold Spring Harbor Laboratory 2552 2553This library is free software; you can redistribute it and/or modify 2554it under the same terms as Perl itself. See DISCLAIMER.txt for 2555disclaimers of warranty. 2556 2557=cut 2558