view release on metacpan or  search on metacpan

lib/Bio/Graphics/Glyph.pm  view on Meta::CPAN

# with values returned by this method in subclasses to
# create a merged hash of all options that can be invoked
#
# retrieve this merged hash with 
# Bio::Graphics::Glyph::the_subclass->options
#
##########################################################
sub my_description {
    return <<END;
This is the base class for all glyphs. It knows how to draw simple
filled and empty boxes. You will want to use the "generic" or
"box" glyphs instead of this one.
END
}

sub my_options {
    return
    {
	height => [
	    'integer',
	    10,
	    'Height of the glyph.'],
	box_subparts=> [
	    'integer',
	    0,
	    'If this option is greater than zero, then imagemaps constructed from this glyph will contain',
	    'bounding boxes around each subpart of a feature (e.g. each exon in a gene). The value of the',
	    'option indicates the depth of recursion.'
	],
	fgcolor => [
	    ['color','featureScore','featureRGB'],
	    'black',
	    'The foreground color of the glyph, used for drawing outlines.',
	    'A value of "featureScore" will produce a greyscale gradient from the',
	    "feature's score value based on a range from 0 (lightest) to 1000 (darkest).",
	    'A value of "featureRGB" will look for a feature tag named "RGB" and use that',
	    'for the color value.',
	    'See the next section for color choices.'],
	bgcolor => [
	    ['color','featureScore','featureRGB'],
	    'turquoise',
	    'The background color of the glyph, used for filling its contents.',
	    'A value of "featureScore" will produce a greyscale gradient from the',
	    "feature's score value based on a range from 0 (lightest) to 1000 (darkest).",
	    'A value of "featureRGB" will look for a feature tag named "RGB" and use that',
	    'for the color value.',
	    'See the next section for color choices.'],
	fillcolor => [
	    'color',
	    'turquoise',
	    'A synonym for -bgcolor.'],
	tkcolor   => [
	    'color',
	    undef,
	    'Rarely-used option to flood-fill entire glyph with a single color',
	    'prior to rendering it.'],
	opacity => [
	    'float',
	    '1.0',
	    'Default opacity to apply to glyph background and foreground colors.',
	    'This is a value between 0.0 (completely transparent) to 1.0 (completely opaque.',
	    'If the color contains an explicit opacity (alpha) value, the default value',
	    'will be ignored'],
	linewidth    => [
	    'integer',
	    1,
	    'Thickness of line used to draw the glyph\'s outline.'],
	strand_arrow => [
	    'boolean',
	    undef,
	    "Whether to indicate the feature's strandedness. If equal to 'ends'",
	    "then only the right and left ends of multi-part features will show",
	    "strandedness."
	],
	stranded => [
	    'boolean',
	    undef,
	    'Synonym for -strand_arrow.',
	    "Indicates whether to indicate the feature's strandedness. If equal to 'ends'",
	    "then only the right and left ends of multi-part features will show",
	    "strandedness."

	],
	key => [
	    'string',
	    undef,
	    'The printed label to use to describe this track.'],
	category => [
	    'string',
	    undef,
	    'A descriptive category that will be added to the track key.'],
	no_subparts => [
	    'boolean',
	    undef,
	    'Set this option to a true value to suppress drawing of all its subparts.'],
	ignore_sub_part => [
	    'string',
	    undef,
	    'Pass a space-delimited list of primary_tag() names in order to selectively',
	    'suppress the drawing of subparts that match those primary tags.'],
	maxdepth => [
	    'integer',
	    undef,
	    'Specifies how many levels deep the glyph should traverse features looking',
	    'for subfeatures. A value of undef allows unlimited traversal. A value of',
	    '0 suppresses traversal entirely for the same effect as -no_subparts.'],
	sort_order => [
	    ['left','right','low_score','high_score','longest','shortest','strand','name'],
	    'left',
	    'Control how features are layed out so that more "important" features sort',
	    'towards the top. See the Bio::Graphics::Glyph documentation for a description of how this' ,
	    'works.'],
	always_sort => [
	    'boolean',
	    undef,
	    'Sort even when bumping is off.'],
	bump => [
	    'integer',
	    1,
	    'This option dictates the behavior of the glyph when two features collide horizontally.',
	    'A value of +1 will bump the colliding feature downward using an algorithm that uses spaces efficiently.',

lib/Bio/Graphics/Glyph.pm  view on Meta::CPAN

   my ($dx,$dy) = @_;
   $self->{left} += $dx;
   $self->{top}  += $dy;

   # because the feature parts use *absolute* not relative addressing
   # we need to move each of the parts horizontally, but not vertically
   $_->move($dx,0) foreach $self->parts;
 }

 # get an option
 sub option {
   my $self = shift;
   my $option_name = shift;
   local $^W=0;
   my @args = ($option_name,@{$self}{qw(partno total_parts)});
   my $factory = $self->{factory} or return;
   return $factory->option($self,@args);
}

# get an option that might be a code reference
sub code_option {
  my $self = shift;
  my $option_name = shift;
  my $factory = $self->factory or return;
  $factory->get_option($option_name);
}

# set an option globally
sub configure {
  my $self = shift;
  my $factory = $self->factory;
  my $option_map = $factory->option_map;
  while (@_) {
    my $option_name  = shift;
    my $option_value = shift;
    ($option_name = lc $option_name) =~ s/^-//;
    $option_map->{$option_name} = $option_value;
  }
}

# some common options
sub color {
  my $self = shift;
  my $color = shift;
  my $index = $self->option($color);
  # turn into a color index
  return $self->translate_color($index) if defined $index;
  return 0;
}

sub translate_color {
  my $self = shift;
  my $color = shift;
  return $self->_translate_color($color);
}

sub _translate_color {
    my $self = shift;
    my $color = shift;
    my $opacity = $self->default_opacity;
    return $opacity < 1 ? $self->factory->transparent_color($opacity,$color) 
                        : $self->factory->translate_color($color);
}

# return value:
#              0    no bumping
#              +1   bump down
#              -1   bump up
#              +2   simple bump down
#              -2   simple bump up
#              +3   optimized (fast) bumping
sub bump {
  my $self = shift;
  my $bump = $self->option('bump');
  return $bump;
}

# control horizontal and vertical collision control
sub hbumppad {
  my $self = shift;
  return $self->{_hbumppad} if exists $self->{_hbumppad};
  my $hbumppad = $self->option('hbumppad');
  $hbumppad    = 2 unless defined $hbumppad;
  return $self->{_hbumppad}= $hbumppad;
}

sub default_opacity {
    my $self = shift;
    return $self->{default_opacity} if defined $self->{default_opacity};
    my $o = $self->option('opacity');
    return $self->{default_opacity} = defined  $o ? $o : 1.0;
}

# we also look for the "color" option for Ace::Graphics compatibility
sub fgcolor {
  my $self  = shift;
  my $fgcolor = $self->option('color') || $self->option('fgcolor');

  my $index   = $fgcolor;
  $index = 'black' unless defined $index;

  if ($index eq 'featureRGB') {
      ($index) = eval{$self->feature->get_tag_values('RGB')};
      $index ||= $fgcolor;
  } elsif ($index eq 'featureScore') {
      $index = $self->score_to_color;
  }
  return $self->_translate_color($index);
}

#add for compatibility
sub fillcolor {
    my $self = shift;
    return $self->bgcolor;
}

# we also look for the "fillcolor" option for Ace::Graphics compatibility
sub bgcolor {
  my $self = shift;
  my ($bgcolor) = eval{$self->feature->get_tag_values('bgcolor')};
  $bgcolor    ||= $self->option('bgcolor'); # Let feature attribute override color