|
0
|
1 =head1 NAME
|
|
|
2
|
|
|
3 Bio::Graphics::Glyph::Factory - Factory for Bio::Graphics::Glyph objects
|
|
|
4
|
|
|
5 =head1 SYNOPSIS
|
|
|
6
|
|
|
7 See L<Bio::Graphics::Panel>.
|
|
|
8
|
|
|
9 =head1 DESCRIPTION
|
|
|
10
|
|
|
11 This class is used internally by Bio::Graphics to generate new Glyph
|
|
|
12 objects by combining a list of features with the user's desired
|
|
|
13 configuration. It is intended to be used internally by Bio::Graphics.
|
|
|
14
|
|
|
15 =head1 FEEDBACK
|
|
|
16
|
|
|
17 =head2 Mailing Lists
|
|
|
18
|
|
|
19 User feedback is an integral part of the evolution of this and other
|
|
|
20 Bioperl modules. Send your comments and suggestions preferably to one
|
|
|
21 of the Bioperl mailing lists. Your participation is much appreciated.
|
|
|
22
|
|
|
23 bioperl-l@bioperl.org - General discussion
|
|
|
24 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
25
|
|
|
26 =head2 Reporting Bugs
|
|
|
27
|
|
|
28 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
29 the bugs and their resolution. Bug reports can be submitted via
|
|
|
30 email or the web:
|
|
|
31
|
|
|
32 bioperl-bugs@bio.perl.org
|
|
|
33 http://bugzilla.bioperl.org/
|
|
|
34
|
|
|
35 =head1 AUTHOR - Lincoln Stein
|
|
|
36
|
|
|
37 Email - lstein@cshl.org
|
|
|
38
|
|
|
39 =head1 SEE ALSO
|
|
|
40
|
|
|
41 L<Bio::Graphics::Panel>
|
|
|
42
|
|
|
43 =head1 APPENDIX
|
|
|
44
|
|
|
45 The rest of the documentation details each of the object
|
|
|
46 methods. Internal methods are usually preceded with an "_"
|
|
|
47 (underscore).
|
|
|
48
|
|
|
49 =cut
|
|
|
50
|
|
|
51 package Bio::Graphics::Glyph::Factory;
|
|
|
52
|
|
|
53 use strict;
|
|
|
54 use Carp qw(:DEFAULT cluck);
|
|
|
55 use GD;
|
|
|
56
|
|
|
57 my %LOADED_GLYPHS = ();
|
|
|
58 my %GENERIC_OPTIONS = (
|
|
|
59 bgcolor => 'turquoise',
|
|
|
60 fgcolor => 'black',
|
|
|
61 fontcolor => 'black',
|
|
|
62 font2color => 'turquoise',
|
|
|
63 height => 8,
|
|
|
64 font => gdSmallFont,
|
|
|
65 bump => +1, # bump by default (perhaps a mistake?)
|
|
|
66 );
|
|
|
67
|
|
|
68 =head2 new
|
|
|
69
|
|
|
70 Title : new
|
|
|
71 Usage : $f = Bio::Graphics::Glyph::Factory->new(
|
|
|
72 -stylesheet => $stylesheet,
|
|
|
73 -glyph_map => $glyph_map,
|
|
|
74 -options => $options);
|
|
|
75 Function : create a new Bio::Graphics::Glyph::Factory object
|
|
|
76 Returns : the new object
|
|
|
77 Args : $stylesheet is a Bio::Das::Stylesheet object that can
|
|
|
78 convert Bio::Das feature objects into glyph names and
|
|
|
79 associated options.
|
|
|
80 $glyph_map is a hash that maps primary tags to glyph names.
|
|
|
81 $options is a hash that maps option names to their values.
|
|
|
82 Status : Internal to Bio::Graphics
|
|
|
83
|
|
|
84 =cut
|
|
|
85
|
|
|
86 sub new {
|
|
|
87 my $class = shift;
|
|
|
88 my $panel = shift;
|
|
|
89 my %args = @_;
|
|
|
90 my $stylesheet = $args{-stylesheet}; # optional, for Bio::Das compatibility
|
|
|
91 my $map = $args{-map}; # map type name to glyph name
|
|
|
92 my $options = $args{-options}; # map type name to glyph options
|
|
|
93 return bless {
|
|
|
94 stylesheet => $stylesheet,
|
|
|
95 glyph_map => $map,
|
|
|
96 options => $options,
|
|
|
97 panel => $panel,
|
|
|
98 },$class;
|
|
|
99 }
|
|
|
100
|
|
|
101 =head2 clone
|
|
|
102
|
|
|
103 Title : clone
|
|
|
104 Usage : $f2 = $f->clone
|
|
|
105 Function : Deep copy of a factory object
|
|
|
106 Returns : a deep copy of the factory object
|
|
|
107 Args : None
|
|
|
108 Status : Internal to Bio::Graphics
|
|
|
109
|
|
|
110 =cut
|
|
|
111
|
|
|
112 sub clone {
|
|
|
113 my $self = shift;
|
|
|
114 my %new = %$self;
|
|
|
115 my $new = bless \%new,ref($self);
|
|
|
116 $new;
|
|
|
117 }
|
|
|
118
|
|
|
119 =head2 stylesheet
|
|
|
120
|
|
|
121 Title : stylesheet
|
|
|
122 Usage : $stylesheet = $f->stylesheet
|
|
|
123 Function : accessor for stylesheet
|
|
|
124 Returns : a Bio::Das::Stylesheet object
|
|
|
125 Args : None
|
|
|
126 Status : Internal to Bio::Graphics
|
|
|
127
|
|
|
128 =cut
|
|
|
129
|
|
|
130 sub stylesheet { shift->{stylesheet} }
|
|
|
131
|
|
|
132 =head2 glyph_map
|
|
|
133
|
|
|
134 Title : glyph_map
|
|
|
135 Usage : $map = $f->glyph_map
|
|
|
136 Function : accessor for the glyph map
|
|
|
137 Returns : a hash mapping primary tags to glyphs
|
|
|
138 Args : None
|
|
|
139 Status : Internal to Bio::Graphics
|
|
|
140
|
|
|
141 =cut
|
|
|
142
|
|
|
143 sub glyph_map { shift->{glyph_map} }
|
|
|
144
|
|
|
145 =head2 option_map
|
|
|
146
|
|
|
147 Title : option_map
|
|
|
148 Usage : $map = $f->option_map
|
|
|
149 Function : accessor for the option map
|
|
|
150 Returns : a hash mapping option names to values
|
|
|
151 Args : None
|
|
|
152 Status : Internal to Bio::Graphics
|
|
|
153
|
|
|
154 =cut
|
|
|
155
|
|
|
156 sub option_map { shift->{options} }
|
|
|
157
|
|
|
158 =head2 global_opts
|
|
|
159
|
|
|
160 Title : global_opts
|
|
|
161 Usage : $map = $f->global_opts
|
|
|
162 Function : accessor for global options
|
|
|
163 Returns : a hash mapping option names to values
|
|
|
164 Args : None
|
|
|
165 Status : Internal to Bio::Graphics
|
|
|
166
|
|
|
167 This returns a set of defaults for option values.
|
|
|
168
|
|
|
169 =cut
|
|
|
170
|
|
|
171 sub global_opts{ shift->{global_opts} }
|
|
|
172
|
|
|
173 =head2 panel
|
|
|
174
|
|
|
175 Title : panel
|
|
|
176 Usage : $panel = $f->panel
|
|
|
177 Function : accessor for Bio::Graphics::Panel
|
|
|
178 Returns : a Bio::Graphics::Panel
|
|
|
179 Args : None
|
|
|
180 Status : Internal to Bio::Graphics
|
|
|
181
|
|
|
182 This returns the panel with which the factory is associated.
|
|
|
183
|
|
|
184 =cut
|
|
|
185
|
|
|
186 sub panel { shift->{panel} }
|
|
|
187
|
|
|
188 =head2 scale
|
|
|
189
|
|
|
190 Title : scale
|
|
|
191 Usage : $scale = $f->scale
|
|
|
192 Function : accessor for the scale
|
|
|
193 Returns : a floating point number
|
|
|
194 Args : None
|
|
|
195 Status : Internal to Bio::Graphics
|
|
|
196
|
|
|
197 This returns the scale, in pixels/bp for glyphs constructed by this
|
|
|
198 factory.
|
|
|
199
|
|
|
200 =cut
|
|
|
201
|
|
|
202 sub scale { shift->{panel}->scale }
|
|
|
203
|
|
|
204 =head2 font
|
|
|
205
|
|
|
206 Title : font
|
|
|
207 Usage : $font = $f->font
|
|
|
208 Function : accessor for the font
|
|
|
209 Returns : a font name
|
|
|
210 Args : None
|
|
|
211 Status : Internal to Bio::Graphics
|
|
|
212
|
|
|
213 This returns a GD font name.
|
|
|
214
|
|
|
215 =cut
|
|
|
216
|
|
|
217 sub font {
|
|
|
218 my $self = shift;
|
|
|
219 my $glyph = shift;
|
|
|
220 $self->option($glyph,'font') || $self->{font};
|
|
|
221 }
|
|
|
222
|
|
|
223 =head2 map_pt
|
|
|
224
|
|
|
225 Title : map_pt
|
|
|
226 Usage : @pixel_positions = $f->map_pt(@bp_positions)
|
|
|
227 Function : map bp positions to pixel positions
|
|
|
228 Returns : a list of pixel positions
|
|
|
229 Args : a list of bp positions
|
|
|
230 Status : Internal to Bio::Graphics
|
|
|
231
|
|
|
232 The real work is done by the panel, but factory subclasses can
|
|
|
233 override if desired.
|
|
|
234
|
|
|
235 =cut
|
|
|
236
|
|
|
237 sub map_pt {
|
|
|
238 my $self = shift;
|
|
|
239 my @result = $self->panel->map_pt(@_);
|
|
|
240 return wantarray ? @result : $result[0];
|
|
|
241 }
|
|
|
242
|
|
|
243 =head2 map_no_trunc
|
|
|
244
|
|
|
245 Title : map_no_trunc
|
|
|
246 Usage : @pixel_positions = $f->map_no_trunc(@bp_positions)
|
|
|
247 Function : map bp positions to pixel positions
|
|
|
248 Returns : a list of pixel positions
|
|
|
249 Args : a list of bp positions
|
|
|
250 Status : Internal to Bio::Graphics
|
|
|
251
|
|
|
252 Same as map_pt(), but it will NOT clip pixel positions to be within
|
|
|
253 the drawing frame.
|
|
|
254
|
|
|
255 =cut
|
|
|
256
|
|
|
257 sub map_no_trunc {
|
|
|
258 my $self = shift;
|
|
|
259 my @result = $self->panel->map_no_trunc(@_);
|
|
|
260 return wantarray ? @result : $result[0];
|
|
|
261 }
|
|
|
262
|
|
|
263 =head2 translate_color
|
|
|
264
|
|
|
265 Title : translate_color
|
|
|
266 Usage : $index = $f->translate_color($color_name)
|
|
|
267 Function : translate symbolic color names into GD indexes
|
|
|
268 Returns : an integer
|
|
|
269 Args : a color name in format "green" or "#00FF00"
|
|
|
270 Status : Internal to Bio::Graphics
|
|
|
271
|
|
|
272 The real work is done by the panel, but factory subclasses can
|
|
|
273 override if desired.
|
|
|
274
|
|
|
275 =cut
|
|
|
276
|
|
|
277 sub translate_color {
|
|
|
278 my $self = shift;
|
|
|
279 my $color_name = shift;
|
|
|
280 $self->panel->translate_color($color_name);
|
|
|
281 }
|
|
|
282
|
|
|
283 =head2 glyph
|
|
|
284
|
|
|
285 Title : glyph
|
|
|
286 Usage : @glyphs = $f->glyph($level,$feature1,$feature2...)
|
|
|
287 Function : transform features into glyphs.
|
|
|
288 Returns : a list of Bio::Graphics::Glyph objects
|
|
|
289 Args : a feature "level", followed by a list of FeatureI objects.
|
|
|
290 Status : Internal to Bio::Graphics
|
|
|
291
|
|
|
292 The level is used to track the level of nesting of features that have
|
|
|
293 subfeatures.
|
|
|
294
|
|
|
295 =cut
|
|
|
296
|
|
|
297 # create a glyph
|
|
|
298 sub make_glyph {
|
|
|
299 my $self = shift;
|
|
|
300 my $level = shift;
|
|
|
301 my @result;
|
|
|
302 my $panel = $self->panel;
|
|
|
303 my ($leftmost,$rightmost) = ($panel->left,$panel->right);
|
|
|
304 my $flip = $panel->flip;
|
|
|
305
|
|
|
306 for my $f (@_) {
|
|
|
307
|
|
|
308 my $type = $self->feature_to_glyph($f);
|
|
|
309 my $glyphclass = 'Bio::Graphics::Glyph';
|
|
|
310 $type ||= 'generic';
|
|
|
311 $glyphclass .= "\:\:\L$type";
|
|
|
312
|
|
|
313 unless ($LOADED_GLYPHS{$glyphclass}++) {
|
|
|
314 carp("the requested glyph class, ``$type'' is not available: $@")
|
|
|
315 unless (eval "require $glyphclass");
|
|
|
316 }
|
|
|
317 my $glyph = $glyphclass->new(-feature => $f,
|
|
|
318 -factory => $self,
|
|
|
319 -flip => $flip,
|
|
|
320 -level => $level);
|
|
|
321
|
|
|
322 # this is removing glyphs that are not onscreen at all.
|
|
|
323 # But never remove tracks!
|
|
|
324 push @result,$glyph if $type eq 'track'
|
|
|
325 || ($glyph->{left} + $glyph->{width} > $leftmost && $glyph->{left} < $rightmost);
|
|
|
326
|
|
|
327 }
|
|
|
328 return wantarray ? @result : $result[0];
|
|
|
329 }
|
|
|
330
|
|
|
331 =head2 feature_to_glyph
|
|
|
332
|
|
|
333 Title : feature_to_glyph
|
|
|
334 Usage : $glyph_name = $f->feature_to_glyph($feature)
|
|
|
335 Function : choose the glyph name given a feature
|
|
|
336 Returns : a glyph name
|
|
|
337 Args : a Bio::Seq::FeatureI object
|
|
|
338 Status : Internal to Bio::Graphics
|
|
|
339
|
|
|
340 =cut
|
|
|
341
|
|
|
342 sub feature_to_glyph {
|
|
|
343 my $self = shift;
|
|
|
344 my $feature = shift;
|
|
|
345
|
|
|
346 return scalar $self->{stylesheet}->glyph($feature) if $self->{stylesheet};
|
|
|
347 my $map = $self->glyph_map or return 'generic';
|
|
|
348 if (ref($map) eq 'CODE') {
|
|
|
349 my $val = eval {$map->($feature)};
|
|
|
350 warn $@ if $@;
|
|
|
351 return $val || 'generic';
|
|
|
352 }
|
|
|
353 return $map->{$feature->primary_tag} || 'generic';
|
|
|
354 }
|
|
|
355
|
|
|
356
|
|
|
357 =head2 set_option
|
|
|
358
|
|
|
359 Title : set_option
|
|
|
360 Usage : $f->set_option($option_name=>$option_value)
|
|
|
361 Function : set or change an option
|
|
|
362 Returns : nothing
|
|
|
363 Args : a name/value pair
|
|
|
364 Status : Internal to Bio::Graphics
|
|
|
365
|
|
|
366 =cut
|
|
|
367
|
|
|
368 sub set_option {
|
|
|
369 my $self = shift;
|
|
|
370 my ($option_name,$option_value) = @_;
|
|
|
371 $self->{overriding_options}{lc $option_name} = $option_value;
|
|
|
372 }
|
|
|
373
|
|
|
374 # options:
|
|
|
375 # the overriding_options hash has precedence
|
|
|
376 # ...followed by the option_map
|
|
|
377 # ...followed by the stylesheet
|
|
|
378 # ...followed by generic options
|
|
|
379 sub option {
|
|
|
380 my $self = shift;
|
|
|
381 my ($glyph,$option_name,$partno,$total_parts) = @_;
|
|
|
382 return unless defined $option_name;
|
|
|
383 $option_name = lc $option_name; # canonicalize
|
|
|
384
|
|
|
385 return $self->{overriding_options}{$option_name}
|
|
|
386 if exists $self->{overriding_options} && exists $self->{overriding_options}{$option_name};
|
|
|
387
|
|
|
388 if (my $map = $self->option_map) {
|
|
|
389 if (defined(my $value = $map->{$option_name})) {
|
|
|
390 my $feature = $glyph->feature;
|
|
|
391 return $value unless ref $value eq 'CODE';
|
|
|
392 return unless $feature->isa('Bio::SeqFeatureI');
|
|
|
393 my $val = eval { $value->($feature,$option_name,$partno,$total_parts,$glyph)};
|
|
|
394 warn $@ if $@;
|
|
|
395 return defined $val && $val eq '*default*' ? $GENERIC_OPTIONS{$option_name} : $val;
|
|
|
396 }
|
|
|
397 }
|
|
|
398
|
|
|
399 if (my $ss = $self->stylesheet) {
|
|
|
400 my($glyph,%options) = $ss->glyph($glyph->feature);
|
|
|
401 my $value = $options{$option_name};
|
|
|
402 return $value if defined $value;
|
|
|
403 }
|
|
|
404
|
|
|
405 return $GENERIC_OPTIONS{$option_name};
|
|
|
406 }
|
|
|
407
|
|
|
408
|
|
|
409 =head2 options
|
|
|
410
|
|
|
411 Title : options
|
|
|
412 Usage : @option_names = $f->options
|
|
|
413 Function : return all configured option names
|
|
|
414 Returns : a list of option names
|
|
|
415 Args : none
|
|
|
416 Status : Internal to Bio::Graphics
|
|
|
417
|
|
|
418 =cut
|
|
|
419
|
|
|
420 # return names of all the options in the option hashes
|
|
|
421 sub options {
|
|
|
422 my $self = shift;
|
|
|
423 my %options;
|
|
|
424 if (my $map = $self->option_map) {
|
|
|
425 $options{lc($_)}++ foreach keys %$map;
|
|
|
426 }
|
|
|
427 $options{lc($_)}++ foreach keys %GENERIC_OPTIONS;
|
|
|
428 return keys %options;
|
|
|
429 }
|
|
|
430
|
|
|
431 1;
|
