SUPER:: results from the CPAN

SUPER::

AcePerl

view release on metacpan or search on metacpan

Ace/Graphics/Glyph.pm view on Meta::CPAN

room in the glyph, you may override calculate_height(),
calculate_left() and calculate_right().  Do not directly override
height(), left() and right(), as their purpose is to cache the values
returned by their calculating cousins in order to avoid time-consuming
recalculation.

A simple draw() method looks like this:

 sub draw {
  my $self = shift;
  $self->SUPER::draw(@_);
  my $gd = shift;

  # and draw a cross through the box
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my $fg = $self->fgcolor;
  $gd->line($x1,$y1,$x2,$y2,$fg);
  $gd->line($x1,$y2,$x2,$y1,$fg);
 }

This subclass draws a simple box with two lines criss-crossed through

Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN

package Ace::Graphics::Glyph::anchored_arrow;
# package to use for drawing an arrow

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub calculate_height {
  my $self = shift;
  my $val = $self->SUPER::calculate_height;
  $val += $self->font->height if $self->option('tick');
  $val;
}

# override draw method
sub draw {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN

package Ace::Graphics::Glyph::arrow;
# package to use for drawing an arrow

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub bottom {
  my $self = shift;
  my $val = $self->SUPER::bottom(@_);
  $val += $self->font->height if $self->option('tick');
  $val += $self->labelheight  if $self->option('label');
  $val;
}

# override draw method
sub draw {
  my $self = shift;
  my $parallel = $self->option('parallel');
  $parallel = 1 unless defined $parallel;

Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN

  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

  my $ne = $self->option('northeast');
  my $sw = $self->option('southwest');
  $ne = $sw = 1 unless defined($ne) || defined($sw);

  # draw a perpendicular arrow at position indicated by $x1
  my $fg = $self->fgcolor;
  my $a2 = $self->SUPER::height/4;

  my @positions = $x1 == $x2 ? ($x1) : ($x1,$x2);
  for my $x (@positions) {
    if ($ne) {
      $gd->line($x,$y1,$x,$y2,$fg);
      $gd->line($x-$a2,$y1+$a2,$x,$y1,$fg);
      $gd->line($x+$a2,$y1+$a2,$x,$y1,$fg);
    }
    if ($sw) {
      $gd->line($x,$y1,$x,$y2,$fg);

Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN

    $self->draw_label($gd,@_);  # this draws the label aligned to the left
  }
}

sub draw_parallel {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

  my $fg = $self->fgcolor;
  my $a2 = $self->SUPER::height/2;
  my $center = $y1+$a2;

  my $ne = $self->option('northeast');
  my $sw = $self->option('southwest');
  # turn on both if neither specified
  $ne = $sw = 1 unless defined($ne) || defined($sw);

  # turn on ticks
  if ($self->option('tick')) {
    my $left = shift;

Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN


    my $first_tick = $interval * int(0.5 + $self->start/$interval);

    for (my $i = $first_tick; $i < $self->end; $i += $interval) {
      my $tickpos = $left + $self->map_pt($i);
      $gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor;
      $gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
    }

    if ($self->option('tick') >= 2) {
      my $a4 = $self->SUPER::height/4;
      for (my $i = $first_tick - $interval; $i < $self->end; $i += $interval/10) {
	my $tickpos = $left + $self->map_pt($i);
	$gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor;
	$gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
      }
    }

    for (my $i = $first_tick; $i < $self->end; $i += $interval) {
      my $tickpos = $left + $self->map_pt($i);
      my $middle = $tickpos - (length($i) * $width)/2;

Ace/Graphics/Glyph/crossbox.pm view on Meta::CPAN

package Ace::Graphics::Glyph::crossbox;

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub draw {
  my $self = shift;
  $self->SUPER::draw(@_);
  my $gd = shift;

  # and draw a cross through the box
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my $fg = $self->fgcolor;
  $gd->line($x1,$y1,$x2,$y2,$fg);
  $gd->line($x1,$y2,$x2,$y1,$fg);
}

1;

Ace/Graphics/Glyph/dot.pm view on Meta::CPAN

package Ace::Graphics::Glyph::dot;
# DAS-compatible package to use for drawing a ring or filled circle

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub draw {
  my $self = shift;
#  $self->SUPER::draw(@_);
  my $gd = shift;
  my $fg = $self->fgcolor;

  # now draw a circle
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my $fg = $self->fgcolor;
  my $xmid   = (($x1+$x2)/2);  my $width  = abs($x2-$x1);
  my $ymid   = (($y1+$y2)/2);  my $height = abs($y2-$y1);

  if ($self->option('point')){

Ace/Graphics/Glyph/graded_segments.pm view on Meta::CPAN

  # which use different names for subparts.
  my @segments;
  my $f = $self->feature;
  if ($f->can('segments')) {
    @segments = $f->segments;

  } elsif ($f->can('sub_SeqFeature')) {
    @segments = $f->sub_SeqFeature;

  } else {
    return $self->SUPER::draw(@_);
  }

  # figure out the colors
  my $max_score = $self->option('max_score');
  unless ($max_score) {
    $max_score = 0;
    foreach (@segments) {
      my $s = eval { $_->score };
      $max_score = $s if $s > $max_score;
    }

Ace/Graphics/Glyph/group.pm view on Meta::CPAN

}

sub members {
  my $self = shift;
  my $m = $self->{members} or return;
  return @$m;
}

sub move {
  my $self = shift;
  $self->SUPER::move(@_);
  $_->move(@_) foreach $self->members;
}

sub left  {  shift->{leftmost}->left   }
sub right {  shift->{rightmost}->right }

sub height {
  my $self = shift;
  $self->{height};
}

Ace/Graphics/Glyph/line.pm view on Meta::CPAN

package Ace::Graphics::Glyph::line;
# an arrow without the arrowheads

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub bottom {
  my $self = shift;
  my $val = $self->SUPER::bottom(@_);
  $val += $self->font->height if $self->option('tick');
  $val += $self->labelheight if $self->option('label');
  $val;
}

sub draw {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

  my $fg = $self->fgcolor;
  my $a2 = $self->SUPER::height/2;
  my $center = $y1+$a2;

  $gd->line($x1,$center,$x2,$center,$fg);
  # add a label if requested
  $self->draw_label($gd,@_) if $self->option('label');

}

1;

Ace/Graphics/Glyph/segments.pm view on Meta::CPAN

use GD;
@ISA = 'Ace::Graphics::Glyph';

use constant GRAY  => 'lightgrey';
my %BRUSHES;

# override right to allow for label
sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);

  if ($self->option('label') && (my $description = $self->description)) {
    my $description_width = $self->font->width * length $self->description;
    $val = $left + $description_width if $left + $description_width > $val;
  }
  $val;
}

# override draw method
sub draw {

Ace/Graphics/Glyph/segments.pm view on Meta::CPAN

  if ($f->can('merged_segments')) {
    @segments = $f->merged_segments;

  } elsif ($f->can('segments')) {
    @segments = $f->segments;

  } elsif ($f->can('sub_SeqFeature')) {
    @segments = $f->sub_SeqFeature;

  } else {
    return $self->SUPER::draw(@_);
  }

  # get parameters
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my ($left,$top) = @_;

  my $gray = $self->color(GRAY);

  my (@boxes,@skips);

Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN

use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

use constant IMPLIED_INTRON_COLOR  => 'gray';
use constant ARROW => 4;

# override the left and right methods in order to
# provide extra room for arrows at the end
sub calculate_left {
  my $self = shift;
  my $val = $self->SUPER::calculate_left(@_);
  $val -= ARROW if $self->feature->strand < 0 && $val >= 4;
  $val;
}

sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);
  $val = $left + ARROW if $left + ARROW > $val;

  if ($self->option('label') && (my $description = $self->description)) {
    my $description_width = $self->font->width * length $description;
    $val = $left + $description_width if $left + $description_width > $val;
  }
  $val;
}

# override the bottom method in order to provide extra room for
# the label
sub calculate_height {
  my $self = shift;
  my $val = $self->SUPER::calculate_height(@_);
  $val += $self->labelheight if $self->option('label') && $self->description;
  $val;
}

# override filled_box method
sub filled_box {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2,$color) = @_;

Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN


  $gd->line($x2,$y1,$x2,$y2,$color)
    if $x2 > $width;
}

# override draw method
sub draw {
  my $self = shift;

  # bail out if this isn't the right kind of feature
  return $self->SUPER::draw(@_) unless $self->feature->can('segments');

  # get parameters
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my ($left,$top) = @_;

  my $implied_intron_color = $self->option('implied_intron_color') || IMPLIED_INTRON_COLOR;
  my $gray = $self->factory->translate($implied_intron_color);
  my $fg     = $self->fgcolor;
  my $fill   = $self->fillcolor;

Ace/Object/Wormbase.pm view on Meta::CPAN

use Carp;
use Ace::Object;

# $Id: Wormbase.pm,v 1.3 2003/12/27 15:52:35 todd Exp $
use vars '@ISA';
@ISA = 'Ace::Object';

# override the Locus method for backward compatibility with model shift
sub Locus {
  my $self = shift;
  return $self->SUPER::Locus(@_) unless $self->class eq 'Sequence';
  if (wantarray) {
    return ($self->Locus_genomic_seq,$self->Locus_other_seq);
  } else {
    return $self->Locus_genomic_seq || $self->Locus_other_seq;
  }
}

sub Sequence {
  my $self = shift;
  return $self->SUPER::Sequence(@_) unless $self->class eq 'Locus';
  if (wantarray) {
#    return ($self->Genomic_sequence,$self->Other_sequence);
    return ($self->CDS,$self->Other_sequence);
  } else {
#    return $self->Genomic_sequence || $self->Other_sequence;
    return $self->CDS || $self->Other_sequence;
  }
}

Ace/Sequence/Feature.pm view on Meta::CPAN

  return wantarray ? @{$self->{group}} : $self->{group}->[0];
}

# bioperl compatibility
sub primary_tag { shift->type(@_)    }
sub source_tag  { shift->subtype(@_) }

sub db { # database identifier (from Ace::Sequence::Multi)
  my $self = shift;
  my $db = $self->_field('db',@_);
  return $db || $self->SUPER::db;
}

sub group  { $_[0]->info; }
sub target { $_[0]->info; }

sub asString {
  my $self = shift;
  my $name = $self->SUPER::asString;
  my $type = $self->type;
  return "$type:$name";
}

# unique ID
sub id {
  my $self = shift;
  my $source = $self->source->name;
  my $start = $self->start;
  my $end = $self->end;

Ace/Sequence/Feature.pm view on Meta::CPAN



__END__
# SCRAPS
# the new() code done "right"
# sub new {
#    my $pack = shift;
#    my ($ref,$r_offset,$r_strand,$gff_line) = @_;
#    my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t";
#    ($start,$end) = ($end,$start) if $strand < 0;
#    my $self = $pack->SUPER::new($source,$start,$end);
#    $self->{info} = {
#  				seqname=> $sourceseq,
#  				method => $method,
#  				type   => $type,
#  				score  => $score,
#  				frame  => $frame,
#  				group  => $group,
#  		  };
#    $self->{fstrand} = $strand;
#    return $self;

Ace/Sequence/Multi.pm view on Meta::CPAN


use vars '@ISA';
@ISA = 'Ace::Sequence';

# backward compatibility
*db_id = \&db;

sub new {
  my $pack = shift;
  my ($secondary,$rest) = rearrange([['SECONDARY','DBS']],@_);
  return unless my $obj = $pack->SUPER::new($rest);

  if (defined $secondary) {
    my @s = ref $secondary eq 'ARRAY' ? @$secondary : $secondary;
    $obj->{'secondary'} = { map { $_=> $_} @s };
  }

  return bless $obj,$pack;
}

sub secondary {

Ace/Sequence/Multi.pm view on Meta::CPAN

}

sub delete_secondary {
  my $self = shift;
  foreach (@_) {
    delete $self->{'secondary'}->{$_};
  }
}

sub db {
  return $_[0]->SUPER::db() unless $_[1];
  return $_[0]->{'secondary'}->{$_[1]} || $_[0]->SUPER::db();
}

# return list of features quickly
sub feature_list {
  my $self = shift;
  return $self->{'feature_list'} if $self->{'feature_list'};
  my $raw;

  for my $db ($self->db,$self->secondary) {
    $raw .= $self->_query($db,'seqfeatures -version 2 -list');

Ace/Sequence/Multi.pm view on Meta::CPAN


  return $self->{'feature_list'} = Ace::Sequence::FeatureList->new($raw);
}

# return a unified gff file
sub gff {
  my $self = shift;
  my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_);
  my   $db = $self->db;

  my $gff = $self->SUPER::gff(-Abs=>$abs,-Features=>$features,-Db=>$db);
  return unless $gff;
  return $gff unless $self->secondary;

  my(%seen,@lines);

  foreach (grep !$seen{$_}++,split("\n",$gff)) {  #ignore duplicates
    next if m!^//!;  # ignore comments
    push @lines,/^\#/ ? $_ : join "\t",$_,$db;
  }

( run in 1.146 second using v1.01-cache-2.11-cpan-49f99fa48dc )