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