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