1
package Bio::Graphics::Glyph::generic;
4
use Bio::Graphics::Util qw(frame_and_offset);
5
use base qw(Bio::Graphics::Glyph);
7
my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',
8
G=>'C',A=>'T',T=>'A',C=>'G');
10
# new options are 'label' -- short label to print over glyph
11
# 'description' -- long label to print under glyph
12
# label and description can be flags or coderefs.
13
# If a flag, label will be taken from seqname, if it exists or primary_tag().
14
# description will be taken from source_tag().
18
my $h = $self->SUPER::height;
20
$self->option('draw_translation') && $self->protein_fits
22
$self->option('draw_dna') && $self->dna_fits;
23
my $fh = $self->font->height + 2;
24
return $h > $fh ? $h : $fh;
29
my $top = $self->option('pad_top');
30
return $top if defined $top;
31
my $pad = $self->SUPER::pad_top;
32
$pad += $self->labelheight if $self->label && $self->label_position eq 'top';
37
my $bottom = $self->option('pad_bottom');
38
return $bottom if defined $bottom;
39
my $pad = $self->SUPER::pad_bottom;
40
$pad += $self->labelheight if $self->description;
41
$pad += $self->labelheight if $self->part_labels && $self->label_position eq 'top';
46
my $pad = $self->SUPER::pad_right;
47
my $label_width = $self->label_position eq 'top' ? $self->labelwidth : 0;
48
my $description_width = $self->descriptionwidth;
49
my $max = $label_width > $description_width ? $label_width : $description_width;
50
my $right = $max - $self->width;
51
return $pad > $right ? $pad : $right;
55
my $pad = $self->SUPER::pad_left;
56
return $pad unless $self->label_position eq 'left' && $self->label;
57
$pad += $self->labelwidth;
62
return $self->getfont('label_font',$self->font);
66
return $self->getfont('desc_font',$self->font);
70
return $self->{labelwidth} ||= length($self->label||'') * $self->font->width;
72
sub descriptionwidth {
74
return $self->{descriptionwidth} ||= length($self->description||'') * $self->font->width;
78
return $self->{labelheight} ||= $self->font->height;
82
return $self->{labelposition} ||= $self->option('label_position') || 'top';
86
return if $self->{overbumped}; # set by the bumper when we have hit bump limit
87
return unless $self->subpart_callbacks; # returns true if this is level 0 or if subpart callbacks allowed
88
return $self->_label if $self->{level} >= 0;
89
return exists $self->{label} ? $self->{label}
90
: ($self->{label} = $self->_label);
94
return if $self->{overbumped}; # set by the bumper when we have hit bump limit
95
return unless $self->subpart_callbacks; # returns true if this is level 0 or if subpart callbacks allowed
96
return $self->_description if $self->{level} > 0;
97
return exists $self->{description} ? $self->{description}
98
: ($self->{description} = $self->_description);
103
my @parts = $self->parts;
104
return ($self->{level} == 0) && @parts && @parts>1 && $self->option('part_labels');
107
sub part_label_merge {
108
shift->option('part_label_merge');
113
my $maxdepth = $self->option('maxdepth');
114
return $maxdepth if defined $maxdepth;
121
# allow caller to specify the label
122
my $label = $self->option('label');
124
return unless defined $label;
125
return "1" if $label eq '1 '; # 1 with a space
126
return $label unless $label eq '1';
128
# figure it out ourselves
129
my $f = $self->feature;
131
return $f->display_name if $f->can('display_name');
132
return $f->info if $f->can('info'); # deprecated API
133
return $f->seq_id if $f->can('seq_id');
134
return eval{$f->primary_tag};
139
# allow caller to specify the long label
140
my $label = $self->option('description');
141
return unless defined $label;
142
return "1" if $label eq '1 ';
143
return $label unless $label eq '1';
145
return $self->{_description} if exists $self->{_description};
146
return $self->{_description} = $self->get_description($self->feature);
149
sub get_description {
153
# common places where we can get descriptions
154
return join '; ',$feature->notes if $feature->can('notes');
155
return $feature->desc if $feature->can('desc');
157
if ($feature->can('has_tag')) {
158
return join '; ',$feature->get_tag_values('note') if $feature->has_tag('note');
159
return join '; ',$feature->get_tag_values('description') if $feature->has_tag('description');
162
my $tag = $feature->source_tag;
163
return if $tag eq '';
169
my ($gd,$left,$top,$partno,$total_parts) = @_;
171
local($self->{partno},$self->{total_parts});
172
@{$self}{qw(partno total_parts)} = ($partno,$total_parts);
174
$self->calculate_cds() if $self->option('draw_translation') && $self->protein_fits;
176
$self->SUPER::draw(@_);
177
$self->draw_label(@_) if $self->option('label');
178
$self->draw_description(@_) if $self->option('description');
179
$self->draw_part_labels(@_) if $self->option('label') && $self->option('part_labels');
184
$self->SUPER::draw_component(@_);
185
$self->draw_translation(@_) if $self->{cds_translation}; # created earlier by calculate_cds()
186
$self->draw_sequence(@_) if $self->option('draw_dna') && $self->dna_fits;
189
# mostly stolen from cds.pm -- draw the protein translation
190
sub draw_translation {
193
my ($x1,$y1,$x2,$y2) = $self->bounds(@_);
195
my $feature = $self->feature;
196
my $strand = $feature->strand;
198
my $font = $self->font;
199
my $pixels_per_residue = $self->scale * 3;
201
my $y = $y1 + ($self->height - $font->height)/2;
202
my $fontwidth = $font->width;
203
my $color = $self->fontcolor;
205
$strand *= -1 if $self->{flip};
207
# have to remap feature start and end into pixel coords in order to:
208
# 1) correctly align the amino acids with the nucleotide seq
209
# 2) correct for the phase offset
210
my $start = $self->map_no_trunc($feature->start + $self->{cds_offset});
211
my $stop = $self->map_no_trunc($feature->end + $self->{cds_offset});
213
($start,$stop) = ($stop,$start) if $stop < $start; # why does this keep happening?
214
my $x_fudge = $self->{flip} ? 1 : 2;
215
my $right = $self->panel->right;
216
my $left = $self->panel->left;
218
my @residues = split '',$self->{cds_translation};
219
push @residues,$self->{cds_splice_residue} if $self->{cds_splice_residue};
220
for (my $i=0;$i<@residues;$i++) {
221
my $x = $strand > 0 ? $start + $i * $pixels_per_residue
222
: $stop - $i * $pixels_per_residue;
223
next unless ($x >= $x1 && $x <= $x2);
224
$x -= $fontwidth + 1 if $self->{flip}; # align right when flipped
225
last if $x+$fontwidth >= $right;
227
$gd->char($font,$x+$x_fudge,$y,$residues[$i],$color);
234
my ($x1,$y1,$x2,$y2) = $self->bounds(@_);
236
my $feature = $self->feature;
237
my $strand = $feature->strand;
239
my $font = $self->font;
240
my $pixels_per_base = $self->scale;
242
my $y = $y1 + ($self->height - $font->height)/2 - 1;
243
my $fontwidth = $font->width;
244
my $color = $self->fontcolor;
246
$strand *= -1 if $self->{flip};
248
# have to remap feature start and end into pixel coords in order to:
249
my $start = $self->map_no_trunc($feature->start);
250
my $stop = $self->map_no_trunc($feature->end);
252
($start,$stop) = ($stop,$start) if $stop < $start; # why does this keep happening?
253
my $x_fudge = $self->{flip} ? 1 : 2;
254
my $right = $self->panel->right;
255
my $left = $self->panel->left;
257
my $seq = $self->get_seq($self->feature->seq);
258
$seq = $seq->seq if $seq; # get the dna
260
my $canonical = $self->option('canonical_strand');
262
my @bases = split '',$seq;
263
for (my $i=0;$i<@bases;$i++) {
264
my $x = $strand >= 0 ? $start + $i * $pixels_per_base
265
: $stop - $i * $pixels_per_base;
266
next unless ($x >= $x1 && $x <= $x2);
267
$x -= $fontwidth + 1 if $self->{flip}; # align right when flipped
269
last if $x + $fontwidth > $right;
271
next if $x >= $right;
274
my $base = $self->{flip} ? $complement{$bases[$i]} : $bases[$i];
275
$base = $complement{$base} if $canonical && $strand < 0;
276
$gd->char($font,$x+$x_fudge,$y,$base,$color);
280
sub min { $_[0] <= $_[1] ? $_[0] : $_[1] }
281
sub max { $_[0] >= $_[1] ? $_[0] : $_[1] }
285
my ($gd,$left,$top,$partno,$total_parts) = @_;
286
my $label = $self->label or return;
287
my $x = $self->left + $left; # valid for both "top" and "left" because the left-hand side is defined by pad_left
288
my $font = $self->labelfont;
289
if ($self->label_position eq 'top') {
290
$x += $self->pad_left; # offset to beginning of the drawn part of the feature
291
$x = $self->panel->left + 1 if $x <= $self->panel->left;
294
$self->top + $top - 1,
298
elsif ($self->label_position eq 'left') {
301
$self->{top} + ($self->height - $font->height)/2 + $top,
306
sub draw_description {
308
my ($gd,$left,$top,$partno,$total_parts) = @_;
309
my $label = $self->description or return;
310
my $x = $self->left + $left;
311
$x += $self->pad_left; # offset to beginning of drawn part of feature
312
$x = $self->panel->left + 1 if $x <= $self->panel->left;
313
my $dy= $self->part_labels ? $self->font->height : 0;
314
$gd->string($self->descfont,
316
$self->bottom - $self->pad_bottom + $top + $dy,
321
sub draw_part_labels {
323
my ($gd,$left,$top,$partno,$total_parts) = @_;
324
return unless $self->{level} == 0;
325
my @p = $self->parts or return;
327
@p = reverse @p if $self->flip;
329
my $font = $self->font;
330
my $width = $font->width;
331
my $color = $self->fontcolor;
333
my $y = $top + $self->bottom - $self->pad_bottom;
334
my $merge_em = $self->part_label_merge;
340
my $current_contig = [];
343
if (!$previous || $part->feature->start - $previous->feature->end <= 1) {
344
push @$current_contig,$part;
346
push @parts,$current_contig;
347
$current_contig = [$part];
351
push @parts,$current_contig;
355
@parts = map {[$_]} @p;
358
my $last_x; # avoid overlapping labels
359
for (my $i=0; $i<@parts; $i++) {
360
my $x1 = $parts[$i][0]->left;
361
my $x2 = $parts[$i][-1]->right;
363
my $string = $self->part_label($i,scalar @parts);
364
my $x = $left + $x1 + ($x2 - $x1 - $width*length($string))/2;
365
my $w = $width * length($string);
366
next if defined $last_x && $self->flip ? $x + $w > $last_x : $x < $last_x;
371
$last_x = $x + ($self->flip ? 0 : $w);
377
my ($part,$total) = @_;
379
local $self->{partno} = $self->feature->strand < 0 ? $total - $part -1 : $part;
380
my $label = $self->option('part_labels');
381
return unless defined $label;
382
return "1" if $label eq '1 ';
383
return $label unless $label eq '1';
384
return $self->{partno}+1;
390
my $pixels_per_base = $self->scale;
391
my $font = $self->font;
392
my $font_width = $font->width;
394
return $pixels_per_base >= $font_width;
399
my $font = $self->font;
401
# return unless $font->height <= $self->height;
403
my $font_width = $font->width;
404
my $pixels_per_residue = $self->scale * 3;
406
return $pixels_per_residue >= $font_width;
412
my ($x,$y,$height,$orientation) = @_;
414
my $fg = $self->set_pen;
415
my $style = $self->option('arrowstyle') || 'regular';
417
if ($style eq 'filled') {
418
my $poly_pkg = $self->polygon_package;
419
my $poly = $poly_pkg->new();
420
if ($orientation >= 0) {
421
$poly->addPt($x-$height,$y-$height);
423
$poly->addPt($x-$height,$y+$height,$y);
425
$poly->addPt($x+$height,$y-$height);
427
$poly->addPt($x+$height,$y+$height,$y);
429
$image->filledPolygon($poly,$fg);
432
if ($orientation >= 0) {
433
$image->line($x,$y,$x-$height,$y-$height,$fg);
434
$image->line($x,$y,$x-$height,$y+$height,$fg);
436
$image->line($x,$y,$x+$height,$y-$height,$fg);
437
$image->line($x,$y,$x+$height,$y+$height,$fg);
445
my ($x1,$x2,$y) = @_;
447
my $fg = $self->set_pen;
448
my $height = $self->height/3;
450
$image->line($x1,$y,$x2,$y,$fg);
451
$self->arrowhead($image,$x2,$y,$height,+1) if $x1 < $x2;
452
$self->arrowhead($image,$x2,$y,$height,-1) if $x2 < $x1;
458
$dna =~ tr/gatcGATC/ctagCTAG/;
463
# this gets invoked if the user has requested that the protein translation
464
# gets drawn using the draw_translation option and protein_fits() returns
465
# true. It is a rather specialized function and possibly belongs somewhere else,
466
# but putting it here makes it possible for any feature to display its protein
470
my @parts = $self->feature_has_subparts ? $self->parts : $self;
472
my $codon_table = $self->option('codontable');
473
$codon_table = 1 unless defined $codon_table;
474
require Bio::Tools::CodonTable unless Bio::Tools::CodonTable->can('new');
475
my $translate_table = Bio::Tools::CodonTable->new(-id=>$codon_table);
477
for (my $i=0; $i < @parts; $i++) {
478
my $part = $parts[$i];
479
my $feature = $part->feature;
481
my $pos = $feature->strand >= 0 ? $feature->start : $feature->end;
482
my $phase = eval {$feature->phase};
483
next unless defined $phase;
484
my $seq = $feature->seq;
485
next unless defined $seq;
487
my $strand = $feature->strand;
488
my ($frame,$offset) = frame_and_offset($pos,
491
$strand *= -1 if $self->{flip};
492
$part->{cds_frame} = $frame;
493
$part->{cds_offset} = $offset;
495
# do in silico splicing in order to find the codon that
496
# arises from the splice
497
my $protein = $seq->translate(undef,undef,$phase,$codon_table)->seq;
498
$part->{cds_translation} = $protein;
501
length $protein >= $feature->length/3 and last BLOCK;
502
($feature->length - $phase) % 3 == 0 and last BLOCK;
504
my $next_part = $parts[$i+1]
506
$part->{cds_splice_residue} = '?';
509
my $next_feature = $next_part->feature or last BLOCK;
510
my $next_phase = eval {$next_feature->phase} or last BLOCK;
511
my $splice_codon = '';
512
my $left_of_splice = substr($self->get_seq($feature->seq), -$next_phase, $next_phase);
513
my $right_of_splice = substr($self->get_seq($next_feature->seq),0 , 3-$next_phase);
514
$splice_codon = $left_of_splice . $right_of_splice;
515
length $splice_codon == 3 or last BLOCK;
516
my $amino_acid = $translate_table->translate($splice_codon);
517
$part->{cds_splice_residue} = $amino_acid;
522
# hack around changed feature API
526
return $seq if ref $seq && $seq->can('translate');
527
require Bio::PrimarySeq unless Bio::PrimarySeq->can('new');
528
return Bio::PrimarySeq->new(-seq=>$seq);
535
Bio::Graphics::Glyph::generic - The "generic" glyph
539
See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
543
This is identical to the "box" glyph except that it will draw the
544
subparts of features that contain subfeatures. The subparts are not
545
connected -- use the "segments" glyph for that. "Generic" is the
546
default glyph used when not otherwise specified.
550
This module overrides the maxdepth() method to return 0 unless the
551
-maxdepth option is provided explicitly. This means that any module
552
that inherits from generic will need to override maxdepth() again in
553
order to draw subfeatures. In general, those implementing
554
multi-segmented feature glyphs should inherit from
555
Bio::Graphics::Glyph::segments, which allows for one level of descent.
557
In addition, the following new methods are implemented:
561
=item labelfont(), descfont(), labelwidth(), descriptionwidth()
563
Return the font, width for the label or description.
567
Return the glyph label text (printed above the glyph).
571
Return the glyph description text (printed below the glyph).
573
=item draw_translation()
575
Draw the protein translation of the feature (assumes that the feature is attached to a DNA sequence).
577
=item draw_sequence()
579
Draw the sequence of the feature (either DNA or protein).
585
The following options are standard among all Glyphs. See
586
L<Bio::Graphics::Glyph> for a full explanation.
588
Option Description Default
589
------ ----------- -------
591
-fgcolor Foreground color black
593
-outlinecolor Synonym for -fgcolor
595
-bgcolor Background color turquoise
597
-fillcolor Synonym for -bgcolor
599
-linewidth Line width 1
601
-height Height of glyph 10
603
-font Default font gdSmallFont
605
-label_font Font used for label gdSmallFont
607
-desc_font Font used for description gdSmallFont
609
-connector Connector type 0 (false)
612
Connector color black
614
-pad_top Top padding 0
616
-pad_bottom Bottom padding 0
618
-label Whether to draw a label 0 (false)
620
-label_position Where to draw the label "top" (default) or "left"
622
-description Whether to draw a description 0 (false)
624
-strand_arrow Whether to indicate 0 (false)
627
-hilite Highlight color undef (no color)
629
-draw_dna If true, draw the dna residues 0 (false)
630
when magnification level
633
-canonical_strand If true, draw the dna residues 0 (false)
634
as they appear on the plus strand
635
even if the feature is on the minus
638
-pad_top and -pad_bottom allow you to insert some blank space between
639
the glyph's boundary and its contents. This is useful if you are
640
changing the glyph's height dynamically based on its feature's score.
648
L<Bio::Graphics::Panel>,
649
L<Bio::Graphics::Glyph>,
650
L<Bio::Graphics::Glyph::arrow>,
651
L<Bio::Graphics::Glyph::cds>,
652
L<Bio::Graphics::Glyph::crossbox>,
653
L<Bio::Graphics::Glyph::diamond>,
654
L<Bio::Graphics::Glyph::dna>,
655
L<Bio::Graphics::Glyph::dot>,
656
L<Bio::Graphics::Glyph::ellipse>,
657
L<Bio::Graphics::Glyph::extending_arrow>,
658
L<Bio::Graphics::Glyph::generic>,
659
L<Bio::Graphics::Glyph::graded_segments>,
660
L<Bio::Graphics::Glyph::heterogeneous_segments>,
661
L<Bio::Graphics::Glyph::line>,
662
L<Bio::Graphics::Glyph::pinsertion>,
663
L<Bio::Graphics::Glyph::primers>,
664
L<Bio::Graphics::Glyph::rndrect>,
665
L<Bio::Graphics::Glyph::segments>,
666
L<Bio::Graphics::Glyph::ruler_arrow>,
667
L<Bio::Graphics::Glyph::toomany>,
668
L<Bio::Graphics::Glyph::transcript>,
669
L<Bio::Graphics::Glyph::transcript2>,
670
L<Bio::Graphics::Glyph::translation>,
671
L<Bio::Graphics::Glyph::triangle>,
672
L<Bio::Graphics::Glyph::xyplot>,
681
Allen Day E<lt>day@cshl.orgE<gt>.
683
Copyright (c) 2001 Cold Spring Harbor Laboratory
685
This library is free software; you can redistribute it and/or modify
686
it under the same terms as Perl itself. See DISCLAIMER.txt for
687
disclaimers of warranty.
added
removed
Bio/Graphics/Glyph/generic.pm
