view release on metacpan or  search on metacpan

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

  my $self    = shift;
  my $s       = $self->option('score');
  return $s   if defined $s;
  return eval { $self->feature->score };
}

sub score2position {
  my $self  = shift;
  my $score = shift;

  return undef unless defined $score;

  if ($self->{_clip_ok} && $score < $self->{_min_score}) {
    return $self->{_bottom};
  }

  elsif ($self->{_clip_ok} && $score > $self->{_max_score}) {
    return $self->{_top};
  }

  else {
    warn "score = $score, _top = $self->{_top}, _bottom = $self->{_bottom}, max = $self->{_max_score}, min=$self->{_min_score}" if DEBUG;
    my $position      = ($score-$self->{_min_score}) * $self->{_scale};
    warn "position =$position" if DEBUG;
    return $self->{_bottom} - $position;
  }
}

sub log10 { log(shift)/log(10) }
sub max10 {
  my $a = shift;
  return 0 if $a==0;
  return -min10(-$a) if $a<0;
  return max10($a*10)/10 if $a < 1;

  my $l=int(log10($a));
  $l = 10**$l; 
  my $r = $a/$l;
  return $r*$l if int($r) == $r;
  return $l*int(($a+$l)/$l);
}
sub min10 {
  my $a = shift;
  return 0 if $a==0;
  return -max10(-$a) if $a<0;
  return min10($a*10)/10 if $a < 1;

  my $l=int(log10($a));
  $l = 10**$l; 
  my $r = $a/$l; 
  return $r*$l if int($r) == $r;
  return $l*int($a/$l);
}

sub _draw_boxes {
  my $self = shift;
  my ($gd,$left,$top,$y_origin) = @_;

  my @parts    = $self->parts;
  my $lw       = $self->linewidth;
  # Make the boxes transparent
  my $positive = $self->pos_color + 1073741824;
  my $negative = $self->neg_color + 1073741824;
  my $height   = $self->height;

  my $midpoint = $self->midpoint ? $self->score2position($self->midpoint) 
                                 : $y_origin;

  my $partcolor = $self->code_option('part_color');
  my $factory  = $self->factory;

  # draw each of the boxes as a rectangle
  for (my $i = 0; $i < @parts; $i++) {

    my $part = $parts[$i];
    my $next = $parts[$i+1];
	
    my ($color,$negcolor);

    # special check here for the part_color being defined so as not to introduce lots of
    # checking overhead when it isn't
    if ($partcolor) {
	$color    = $self->translate_color($factory->option($part,'part_color',0,0));
	$negcolor = $color;
    } else {
	$color    = $positive;
	$negcolor = $negative;
    }

    my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
    next unless defined $part->{_y_position};
    # prevent boxes from being less than 1 pixel
    $x2 = $x1+1 if $x2-$x1 < 1;
    if ($part->{_y_position} < $midpoint) {
	$gd->filledRectangle($x1,$part->{_y_position},$x2,$y_origin,$color);
    } else {
	$gd->filledRectangle($x1,$y_origin,$x2,$part->{_y_position},$negcolor);
    }
  }

  # That's it.
}

sub _draw_line {
  my $self = shift;
  my ($gd,$left,$top) = @_;

  my @parts  = $self->parts;
  my $fgcolor = $self->fgcolor;
  my $bgcolor = $self->bgcolor;

  # connect to center positions of each interval
  my $first_part = shift @parts;
  my ($x1,$y1,$x2,$y2) = $first_part->calculate_boundaries($left,$top);
  my $current_x = ($x1+$x2)/2;
  my $current_y = $first_part->{_y_position};

  for my $part (@parts) {  
    
    ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
    my $next_x = ($x1+$x2)/2;