Bio-Graphics

 view release on metacpan or  search on metacpan

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

  my $pad = $self->SUPER::pad_top;
  $pad   += $self->labelheight if $self->label && $self->label_position eq 'top';
  $pad;
}
sub pad_bottom {
  my $self = shift;
  my $bottom  = $self->option('pad_bottom');
  return $bottom if defined $bottom;
  my $pad = $self->SUPER::pad_bottom;
  $pad   += $self->labelheight+6 if $self->description;
  $pad   += $self->labelheight+6 if $self->part_labels && $self->label_position eq 'top';
  $pad;
}
sub pad_right {
  my $self = shift;
  my $pad = $self->SUPER::pad_right;
  return $pad unless $self->label;
  my $label_width       = $self->label_position eq 'top' ? $self->labelwidth : 0;
  my $description_width = $self->descriptionwidth;
  my $max = $label_width > $description_width ? $label_width : $description_width;
  my $right = $max - $self->width;
  return $pad > $right ? $pad : $right;
}
sub pad_left {
  my $self = shift;
  my $pad = $self->SUPER::pad_left;
  return $pad unless $self->label_position eq 'left' && $self->label;
  $pad += $self->labelwidth + 3;
  $pad;
}
sub labelfont {
  my $self = shift;
  my $font = $self->getfont('label_font',$self->font);
  $font = GD->gdTinyFont if $self->string_height($font) > $self->height && $self->label_position eq 'left';
  return $font;
}
sub descfont {
  my $self = shift;
  return $self->getfont('desc_font',$self->font);
}
sub labelwidth {
  my $self = shift;
  return $self->{labelwidth} ||= $self->string_width($self->label||'',$self->labelfont);
}
sub descriptionwidth {
  my $self = shift;
  return $self->{descriptionwidth} ||= $self->string_width($self->description||'',$self->descfont);
}
sub labelheight {
  my $self = shift;
  return $self->{labelheight} ||= $self->string_height($self->labelfont);
}
sub label_position {
  my $self = shift;
  return $self->{labelposition} ||= $self->option('label_position') || 'top';
}
sub label {
  my $self = shift;

  return if $self->{overbumped};  # set by the bumper when we have hit bump limit
  return unless $self->subpart_callbacks;  # returns true if this is level 0 or if subpart callbacks allowed
  return $self->_label if $self->{level} >= 0;

  return exists $self->{label} ? $self->{label}
                               : ($self->{label} = $self->_label);
}
sub description {
  my $self = shift;
  return if $self->{overbumped}; # set by the bumper when we have hit bump limit
  return unless $self->subpart_callbacks;  # returns true if this is level 0 or if subpart callbacks allowed
  return $self->_description if $self->{level} > 0;
  return exists $self->{description} ? $self->{description}
                                     : ($self->{description} = $self->_description);
}

sub part_labels {
  my $self = shift;
  my @parts = $self->parts;
  return ($self->{level} == 0) && @parts && @parts>1 && $self->option('part_labels');
}

sub part_label_merge {
  shift->option('part_label_merge');
}

sub maxdepth {
  my $self = shift;
  my $maxdepth =  $self->option('maxdepth');
  return $maxdepth if defined $maxdepth;
  return 1;
}

sub _label {
  my $self = shift;

  # allow caller to specify the label
  my $label = $self->option('label');

  return unless defined $label;
  return "1"    if $label eq '1 '; # 1 with a space
  return $label unless $label eq '1';

  # figure it out ourselves
  my $f = $self->feature;

  if ($f->can('display_name') && (my $name = $f->display_name)) {
      return $name;
  }

  if ($f->can('attributes') && (my @aliases = $f->attributes('Alias'))) {
      return $aliases[0];
  }
  return $f->info         if $f->can('info');   # deprecated API
  return $f->seq_id       if $f->can('seq_id');
  return eval{$f->primary_tag};
}
sub _description {
  my $self = shift;

  # allow caller to specify the long label
  my $label = $self->option('description');
  return unless defined $label;
  return "1"   if $label eq '1 ';
  return $label unless $label eq '1';

  return $self->{_description} if exists $self->{_description};
  return $self->{_description} = $self->get_description($self->feature);
}

sub get_description {



( run in 1.564 second using v1.01-cache-2.11-cpan-39bf76dae61 )