← Back to branch summary

~ubuntu-branches/ubuntu/saucy/bioperl/saucy-proposed

« back to all changes in this revision

Viewing changes to Bio/Graphics/Glyph/Factory.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20090310071911-fukqzw54pyb1f0bd
Tags: 1.6.0-2
https://launchpad.net/bugs/324001
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Graphics/Glyph/Factory.pm
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/wiki/Mailing_lists  - 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 the
30
 
web:
31
 
 
32
 
  http://bugzilla.open-bio.org/
33
 
 
34
 
=head1 AUTHOR - Lincoln Stein
35
 
 
36
 
Email - lstein@cshl.org
37
 
 
38
 
=head1 SEE ALSO
39
 
 
40
 
L<Bio::Graphics::Panel>
41
 
 
42
 
=head1 APPENDIX
43
 
 
44
 
The rest of the documentation details each of the object
45
 
methods. Internal methods are usually preceded with an "_"
46
 
(underscore).
47
 
 
48
 
=cut
49
 
 
50
 
package Bio::Graphics::Glyph::Factory;
51
 
 
52
 
use strict;
53
 
use Carp qw(:DEFAULT cluck);
54
 
use Bio::Root::Version;
55
 
use base qw(Bio::Root::Root);
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', # This must be a string not method call
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 $flip   = $panel->flip;
304
 
 
305
 
  for my $f (@_) {
306
 
    my $type = $self->feature_to_glyph($f);
307
 
    my $glyphclass = 'Bio::Graphics::Glyph';
308
 
    $type ||= 'generic';
309
 
    $glyphclass .= "\:\:\L$type";
310
 
 
311
 
    unless ($LOADED_GLYPHS{$glyphclass}++) {
312
 
      $self->throw("The requested glyph class, ``$type'' is not available: $@")
313
 
        unless (eval "require $glyphclass");
314
 
    }
315
 
 
316
 
    my $glyph = $glyphclass->new(-feature  => $f,
317
 
                                 -factory  => $self,
318
 
                                 -flip     => $flip,
319
 
                                 -level    => $level);
320
 
 
321
 
    push @result,$glyph;
322
 
 
323
 
  }
324
 
  return wantarray ? @result : $result[0];
325
 
}
326
 
 
327
 
=head2 feature_to_glyph
328
 
 
329
 
  Title    : feature_to_glyph
330
 
  Usage    : $glyph_name = $f->feature_to_glyph($feature)
331
 
  Function : choose the glyph name given a feature
332
 
  Returns  : a glyph name
333
 
  Args     : a Bio::Seq::FeatureI object
334
 
  Status   : Internal to Bio::Graphics
335
 
 
336
 
=cut
337
 
 
338
 
sub feature_to_glyph {
339
 
  my $self    = shift;
340
 
  my $feature = shift;
341
 
 
342
 
  return scalar $self->{stylesheet}->glyph($feature) if $self->{stylesheet};
343
 
  my $map = $self->glyph_map    or return 'generic';
344
 
  if (ref($map) eq 'CODE') {
345
 
    my $val = eval {$map->($feature)};
346
 
    warn $@ if $@;
347
 
    return $val || 'generic';
348
 
  }
349
 
  return $map->{$feature->primary_tag} || 'generic';
350
 
}
351
 
 
352
 
 
353
 
=head2 set_option
354
 
 
355
 
  Title    : set_option
356
 
  Usage    : $f->set_option($option_name=>$option_value)
357
 
  Function : set or change an option
358
 
  Returns  : nothing
359
 
  Args     : a name/value pair
360
 
  Status   : Internal to Bio::Graphics
361
 
 
362
 
=cut
363
 
 
364
 
sub set_option {
365
 
  my $self = shift;
366
 
  my ($option_name,$option_value) = @_;
367
 
  $self->{overriding_options}{lc $option_name} = $option_value;
368
 
}
369
 
 
370
 
# options:
371
 
#    the overriding_options hash has precedence
372
 
#    ...followed by the option_map
373
 
#    ...followed by the stylesheet
374
 
#    ...followed by generic options
375
 
sub option {
376
 
  my $self = shift;
377
 
  my ($glyph,$option_name,$partno,$total_parts) = @_;
378
 
  return unless defined $option_name;
379
 
  $option_name = lc $option_name;   # canonicalize
380
 
 
381
 
  return $self->{overriding_options}{$option_name} 
382
 
    if exists $self->{overriding_options} && exists $self->{overriding_options}{$option_name};
383
 
 
384
 
  if (exists $self->{options} && (my $map    = $self->{options})) {
385
 
    if (exists $map->{$option_name} && defined(my $value  = $map->{$option_name})) {
386
 
      my $feature = $glyph->feature;
387
 
      return $value unless ref $value eq 'CODE';
388
 
      my $val = eval { $value->($feature,$option_name,$partno,$total_parts,$glyph)};
389
 
      warn "Error returned while evaluating value of '$option_name' option for glyph $glyph, feature $feature: ",$@,"\n"
390
 
        if $@;
391
 
      return defined $val && $val eq '*default*' ? $GENERIC_OPTIONS{$option_name} : $val;
392
 
    }
393
 
  }
394
 
 
395
 
  if (exists $self->{stylesheet} && (my $ss = $self->{stylesheet})) {
396
 
    my($glyph,%options) = $ss->glyph($glyph->feature);
397
 
    my $value = $options{$option_name};
398
 
    return $value if defined $value;
399
 
  }
400
 
 
401
 
  return $GENERIC_OPTIONS{$option_name};
402
 
}
403
 
 
404
 
sub get_option {
405
 
  my $self = shift;
406
 
  my $option_name = shift;
407
 
  my $map = $self->{options} or return;
408
 
  $map->{$option_name};
409
 
}
410
 
 
411
 
 
412
 
=head2 options
413
 
 
414
 
  Title    : options
415
 
  Usage    : @option_names = $f->options
416
 
  Function : return all configured option names
417
 
  Returns  : a list of option names
418
 
  Args     : none
419
 
  Status   : Internal to Bio::Graphics
420
 
 
421
 
=cut
422
 
 
423
 
# return names of all the options in the option hashes
424
 
sub options {
425
 
  my $self = shift;
426
 
  my %options;
427
 
  if (my $map    = $self->option_map) {
428
 
    $options{lc($_)}++ foreach keys %$map;
429
 
  }
430
 
  $options{lc($_)}++ foreach keys %GENERIC_OPTIONS;
431
 
  return keys %options;
432
 
}
433
 
 
434
 
1;