|
0
|
1 package Bio::Graphics::Glyph::generic;
|
|
|
2
|
|
|
3 use strict;
|
|
|
4 use Bio::Graphics::Glyph;
|
|
|
5 use vars '@ISA';
|
|
|
6 @ISA = 'Bio::Graphics::Glyph';
|
|
|
7
|
|
|
8 my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',
|
|
|
9 G=>'C',A=>'T',T=>'A',C=>'G');
|
|
|
10
|
|
|
11 # new options are 'label' -- short label to print over glyph
|
|
|
12 # 'description' -- long label to print under glyph
|
|
|
13 # label and description can be flags or coderefs.
|
|
|
14 # If a flag, label will be taken from seqname, if it exists or primary_tag().
|
|
|
15 # description will be taken from source_tag().
|
|
|
16
|
|
|
17 sub pad_top {
|
|
|
18 my $self = shift;
|
|
|
19 my $top = $self->option('pad_top');
|
|
|
20 return $top if defined $top;
|
|
|
21 my $pad = $self->SUPER::pad_top;
|
|
|
22 $pad += $self->labelheight if $self->label;
|
|
|
23 $pad;
|
|
|
24 }
|
|
|
25 sub pad_bottom {
|
|
|
26 my $self = shift;
|
|
|
27 my $bottom = $self->option('pad_bottom');
|
|
|
28 return $bottom if defined $bottom;
|
|
|
29 my $pad = $self->SUPER::pad_bottom;
|
|
|
30 $pad += $self->labelheight if $self->description;
|
|
|
31 $pad;
|
|
|
32 }
|
|
|
33 sub pad_right {
|
|
|
34 my $self = shift;
|
|
|
35 my $pad = $self->SUPER::pad_right;
|
|
|
36 my $label_width = length($self->label||'') * $self->font->width;
|
|
|
37 my $description_width = length($self->description||'') * $self->font->width;
|
|
|
38 my $max = $label_width > $description_width ? $label_width : $description_width;
|
|
|
39 my $right = $max - $self->width;
|
|
|
40 return $pad > $right ? $pad : $right;
|
|
|
41 }
|
|
|
42
|
|
|
43 sub labelheight {
|
|
|
44 my $self = shift;
|
|
|
45 return $self->{labelheight} ||= $self->font->height;
|
|
|
46 }
|
|
|
47 sub label {
|
|
|
48 my $self = shift;
|
|
|
49 return if $self->{overbumped}; # set by the bumper when we have hit bump limit
|
|
|
50 return unless $self->{level} == 0;
|
|
|
51 return exists $self->{label} ? $self->{label}
|
|
|
52 : ($self->{label} = $self->_label);
|
|
|
53 }
|
|
|
54 sub description {
|
|
|
55 my $self = shift;
|
|
|
56 return if $self->{overbumped}; # set by the bumper when we have hit bump limit
|
|
|
57 return unless $self->{level} == 0;
|
|
|
58 return exists $self->{description} ? $self->{description}
|
|
|
59 : ($self->{description} = $self->_description);
|
|
|
60 }
|
|
|
61 sub _label {
|
|
|
62 my $self = shift;
|
|
|
63
|
|
|
64 # allow caller to specify the label
|
|
|
65 my $label = $self->option('label');
|
|
|
66 return unless defined $label;
|
|
|
67 return $label unless $label eq '1';
|
|
|
68 return "1" if $label eq '1 '; # 1 with a space
|
|
|
69
|
|
|
70
|
|
|
71 # figure it out ourselves
|
|
|
72 my $f = $self->feature;
|
|
|
73
|
|
|
74 return $f->display_name if $f->can('display_name');
|
|
|
75 return $f->info if $f->can('info'); # deprecated API
|
|
|
76 return $f->seq_id if $f->can('seq_id');
|
|
|
77 return eval{$f->primary_tag};
|
|
|
78 }
|
|
|
79 sub _description {
|
|
|
80 my $self = shift;
|
|
|
81
|
|
|
82 # allow caller to specify the long label
|
|
|
83 my $label = $self->option('description');
|
|
|
84 return unless defined $label;
|
|
|
85 return $label unless $label eq '1';
|
|
|
86 return "1" if $label eq '1 ';
|
|
|
87
|
|
|
88 return $self->{_description} if exists $self->{_description};
|
|
|
89 return $self->{_description} = $self->get_description($self->feature);
|
|
|
90 }
|
|
|
91
|
|
|
92 sub get_description {
|
|
|
93 my $self = shift;
|
|
|
94 my $feature = shift;
|
|
|
95
|
|
|
96 # common places where we can get descriptions
|
|
|
97 return join '; ',$feature->notes if $feature->can('notes');
|
|
|
98 return $feature->desc if $feature->can('desc');
|
|
|
99
|
|
|
100 my $tag = $feature->source_tag;
|
|
|
101 return undef if $tag eq '';
|
|
|
102 $tag;
|
|
|
103 }
|
|
|
104
|
|
|
105 sub draw {
|
|
|
106 my $self = shift;
|
|
|
107 $self->SUPER::draw(@_);
|
|
|
108 $self->draw_label(@_) if $self->option('label');
|
|
|
109 $self->draw_description(@_) if $self->option('description');
|
|
|
110 }
|
|
|
111
|
|
|
112 sub draw_label {
|
|
|
113 my $self = shift;
|
|
|
114 my ($gd,$left,$top,$partno,$total_parts) = @_;
|
|
|
115 my $label = $self->label or return;
|
|
|
116 my $x = $self->left + $left;
|
|
|
117 $x = $self->panel->left + 1 if $x <= $self->panel->left;
|
|
|
118 my $font = $self->option('labelfont') || $self->font;
|
|
|
119 $gd->string($font,
|
|
|
120 $x,
|
|
|
121 $self->top + $top,
|
|
|
122 $label,
|
|
|
123 $self->fontcolor);
|
|
|
124 }
|
|
|
125 sub draw_description {
|
|
|
126 my $self = shift;
|
|
|
127 my ($gd,$left,$top,$partno,$total_parts) = @_;
|
|
|
128 my $label = $self->description or return;
|
|
|
129 my $x = $self->left + $left;
|
|
|
130 $x = $self->panel->left + 1 if $x <= $self->panel->left;
|
|
|
131 $gd->string($self->font,
|
|
|
132 $x,
|
|
|
133 $self->bottom - $self->pad_bottom + $top,
|
|
|
134 $label,
|
|
|
135 $self->font2color);
|
|
|
136 }
|
|
|
137
|
|
|
138 sub dna_fits {
|
|
|
139 my $self = shift;
|
|
|
140
|
|
|
141 my $pixels_per_base = $self->scale;
|
|
|
142 my $font = $self->font;
|
|
|
143 my $font_width = $font->width;
|
|
|
144
|
|
|
145 return $pixels_per_base >= $font_width;
|
|
|
146 }
|
|
|
147
|
|
|
148 sub arrowhead {
|
|
|
149 my $self = shift;
|
|
|
150 my $gd = shift;
|
|
|
151 my ($x,$y,$height,$orientation) = @_;
|
|
|
152
|
|
|
153 my $fg = $self->set_pen;
|
|
|
154 my $style = $self->option('arrowstyle') || 'regular';
|
|
|
155
|
|
|
156 if ($style eq 'filled') {
|
|
|
157 my $poly = new GD::Polygon;
|
|
|
158 if ($orientation >= 0) {
|
|
|
159 $poly->addPt($x-$height,$y-$height);
|
|
|
160 $poly->addPt($x,$y);
|
|
|
161 $poly->addPt($x-$height,$y+$height,$y);
|
|
|
162 } else {
|
|
|
163 $poly->addPt($x+$height,$y-$height);
|
|
|
164 $poly->addPt($x,$y);
|
|
|
165 $poly->addPt($x+$height,$y+$height,$y);
|
|
|
166 }
|
|
|
167 $gd->filledPolygon($poly,$fg);
|
|
|
168 } else {
|
|
|
169 if ($orientation >= 0) {
|
|
|
170 $gd->line($x-$height,$y-$height,$x,$y,$fg);
|
|
|
171 $gd->line($x,$y,$x-$height,$y+$height,$fg);
|
|
|
172 } else {
|
|
|
173 $gd->line($x+$height,$y-$height,$x,$y,$fg);
|
|
|
174 $gd->line($x,$y,$x+$height,$y+$height,$fg);
|
|
|
175 }
|
|
|
176 }
|
|
|
177 }
|
|
|
178
|
|
|
179 sub arrow {
|
|
|
180 my $self = shift;
|
|
|
181 my $gd = shift;
|
|
|
182 my ($x1,$x2,$y) = @_;
|
|
|
183
|
|
|
184 my $fg = $self->set_pen;
|
|
|
185 my $height = $self->height/3;
|
|
|
186
|
|
|
187 $gd->line($x1,$y,$x2,$y,$fg);
|
|
|
188 $self->arrowhead($gd,$x2,$y,$height,+1) if $x1 < $x2;
|
|
|
189 $self->arrowhead($gd,$x2,$y,$height,-1) if $x2 < $x1;
|
|
|
190 }
|
|
|
191
|
|
|
192 sub reversec {
|
|
|
193 $_[1]=~tr/gatcGATC/ctagCTAG/;
|
|
|
194 return scalar reverse $_[1];
|
|
|
195 }
|
|
|
196
|
|
|
197 1;
|
|
|
198
|
|
|
199 =head1 NAME
|
|
|
200
|
|
|
201 Bio::Graphics::Glyph::generic - The "generic" glyph
|
|
|
202
|
|
|
203 =head1 SYNOPSIS
|
|
|
204
|
|
|
205 See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
|
|
|
206
|
|
|
207 =head1 DESCRIPTION
|
|
|
208
|
|
|
209 This is identical to the "box" glyph. It is the default glyph used
|
|
|
210 when not otherwise specified.
|
|
|
211
|
|
|
212 =head2 OPTIONS
|
|
|
213
|
|
|
214 The following options are standard among all Glyphs. See
|
|
|
215 L<Bio::Graphics::Glyph> for a full explanation.
|
|
|
216
|
|
|
217 Option Description Default
|
|
|
218 ------ ----------- -------
|
|
|
219
|
|
|
220 -fgcolor Foreground color black
|
|
|
221
|
|
|
222 -outlinecolor Synonym for -fgcolor
|
|
|
223
|
|
|
224 -bgcolor Background color turquoise
|
|
|
225
|
|
|
226 -fillcolor Synonym for -bgcolor
|
|
|
227
|
|
|
228 -linewidth Line width 1
|
|
|
229
|
|
|
230 -height Height of glyph 10
|
|
|
231
|
|
|
232 -font Glyph font gdSmallFont
|
|
|
233
|
|
|
234 -connector Connector type 0 (false)
|
|
|
235
|
|
|
236 -connector_color
|
|
|
237 Connector color black
|
|
|
238
|
|
|
239 -pad_top Top padding 0
|
|
|
240
|
|
|
241 -pad_bottom Bottom padding 0
|
|
|
242
|
|
|
243 -label Whether to draw a label 0 (false)
|
|
|
244
|
|
|
245 -description Whether to draw a description 0 (false)
|
|
|
246
|
|
|
247 -strand_arrow Whether to indicate 0 (false)
|
|
|
248 strandedness
|
|
|
249
|
|
|
250 -pad_top and -pad_bottom allow you to insert some blank space between
|
|
|
251 the glyph's boundary and its contents. This is useful if you are
|
|
|
252 changing the glyph's height dynamically based on its feature's score.
|
|
|
253
|
|
|
254 =head1 BUGS
|
|
|
255
|
|
|
256 Please report them.
|
|
|
257
|
|
|
258 =head1 SEE ALSO
|
|
|
259
|
|
|
260 L<Bio::Graphics::Panel>,
|
|
|
261 L<Bio::Graphics::Glyph>,
|
|
|
262 L<Bio::Graphics::Glyph::arrow>,
|
|
|
263 L<Bio::Graphics::Glyph::cds>,
|
|
|
264 L<Bio::Graphics::Glyph::crossbox>,
|
|
|
265 L<Bio::Graphics::Glyph::diamond>,
|
|
|
266 L<Bio::Graphics::Glyph::dna>,
|
|
|
267 L<Bio::Graphics::Glyph::dot>,
|
|
|
268 L<Bio::Graphics::Glyph::ellipse>,
|
|
|
269 L<Bio::Graphics::Glyph::extending_arrow>,
|
|
|
270 L<Bio::Graphics::Glyph::generic>,
|
|
|
271 L<Bio::Graphics::Glyph::graded_segments>,
|
|
|
272 L<Bio::Graphics::Glyph::heterogeneous_segments>,
|
|
|
273 L<Bio::Graphics::Glyph::line>,
|
|
|
274 L<Bio::Graphics::Glyph::pinsertion>,
|
|
|
275 L<Bio::Graphics::Glyph::primers>,
|
|
|
276 L<Bio::Graphics::Glyph::rndrect>,
|
|
|
277 L<Bio::Graphics::Glyph::segments>,
|
|
|
278 L<Bio::Graphics::Glyph::ruler_arrow>,
|
|
|
279 L<Bio::Graphics::Glyph::toomany>,
|
|
|
280 L<Bio::Graphics::Glyph::transcript>,
|
|
|
281 L<Bio::Graphics::Glyph::transcript2>,
|
|
|
282 L<Bio::Graphics::Glyph::translation>,
|
|
|
283 L<Bio::Graphics::Glyph::triangle>,
|
|
|
284 L<Bio::DB::GFF>,
|
|
|
285 L<Bio::SeqI>,
|
|
|
286 L<Bio::SeqFeatureI>,
|
|
|
287 L<Bio::Das>,
|
|
|
288 L<GD>
|
|
|
289
|
|
|
290 =head1 AUTHOR
|
|
|
291
|
|
|
292 Allen Day E<lt>day@cshl.orgE<gt>.
|
|
|
293
|
|
|
294 Copyright (c) 2001 Cold Spring Harbor Laboratory
|
|
|
295
|
|
|
296 This library is free software; you can redistribute it and/or modify
|
|
|
297 it under the same terms as Perl itself. See DISCLAIMER.txt for
|
|
|
298 disclaimers of warranty.
|
|
|
299
|
|
|
300 =cut
|
