[Bioperl-guts-l] bioperl-live/Bio/Graphics/Glyph stackedplot.pm, NONE, 1.1 xyplot.pm, 1.29, 1.30

Lincoln Stein lstein at dev.open-bio.org
Wed Dec 20 18:35:05 EST 2006


Update of /home/repository/bioperl/bioperl-live/Bio/Graphics/Glyph
In directory dev.open-bio.org:/tmp/cvs-serv1568/Bio/Graphics/Glyph

Modified Files:
	xyplot.pm 
Added Files:
	stackedplot.pm 
Log Message:
featurefile no longer ignores #anchor notation in configured urls; added a primitive stackplot glyph

--- NEW FILE: stackedplot.pm ---
package Bio::Graphics::Glyph::stackedplot;

use strict;
use base 'Bio::Graphics::Glyph::xyplot';
use Carp 'cluck';

use constant TOP_SPACING => 12;

sub width_needed {
  my $self = shift;
  my $column_width   = $self->column_width;
  my $column_spacing = $self->column_spacing;
  my $scale_width    = $self->scale_width;
  my $columns        = $self->data_series;
  return (@$columns-2) * $column_width + (@$columns-1)*$column_spacing + $scale_width;
}


sub pad_top {
  my $self    = shift;
  my $top  = $self->SUPER::pad_top;
  return $top + TOP_SPACING + $self->delegate_height;
}
sub pad_bottom {
  my $self = shift;
  my @labels  = $self->category_labels;
  return $self->SUPER::pad_bottom unless @labels;
  return $self->font('gdTinyFont')->height;
}

sub column_width    { shift->option('column_width')     || 4  }
sub column_spacing  { shift->option('column_spacing')   || 2  }
sub delegate_height { shift->option('delegate_height')  || 8  }
sub scale_width     { shift->option('scale_width')      || 20 }

sub pad_left {
  my $self = shift;
  my $pad          = $self->SUPER::pad_left;
  my $width_needed = ($self->width_needed - $self->width)/2;
  return $pad > $width_needed ? $pad : $width_needed;
}

sub pad_right {
   my $self = shift;
   my $pad          = $self->SUPER::pad_right;
   my $width_needed = ($self->width_needed - $self->width)/2;
   return $pad > $width_needed ? $pad : $width_needed;
}

sub maxdepth { 0 }

# this behaves more like the image glyph -- it draws a generic glyph, two diagonal lines, and then the
# plot underneath.
sub draw {
   my $self = shift;
   my $gd       = shift;
   my ($dx,$dy) = @_;
   my($x1,$y1,$x2,$y2) = $self->bounds($dx,$dy);

   my $top = $y1 - $self->pad_top;
   my $bottom = $y2;
   $self->filled_box($gd,$x1,$top,$x2,$top+6);

  my $width        = $self->width_needed;
  my $graph_top    = $y1;
  my $xmid         = ($x1+$x2) / 2;
  my $graph_left   = $xmid - $width/2;
  my $graph_right  = $xmid + $width/2;
  my $fgcolor      = $self->fgcolor;

  if (TOP_SPACING > 0) {
    $top += 6;
    $gd->line($x1,$top+2,$x1,$top+4,$fgcolor);
    $gd->line($x2,$top+2,$x2,$top+4,$fgcolor);
    $gd->line($x1,$top+4,$graph_left,$y1-4,$fgcolor);
    $gd->line($x2,$top+4,$graph_right,$y1-4,$fgcolor);
    $gd->line($graph_left,$y1-4,$graph_left,$y1-2,$fgcolor);
    $gd->line($graph_right,$y1-4,$graph_right,$y1-2,$fgcolor);
  }

   my $min_score = $self->option('min_score') || 0.0;
   my $max_score = $self->option('max_score') || 1.0;
   my $height = $self->height;
   my $scale  = $max_score > $min_score ? $height/($max_score-$min_score) : 1;
   my $y_origin = $min_score <= 0 ? $bottom - (0 - $min_score) * $scale : $bottom;
   $y_origin    = $top if $max_score < 0;
   $self->_draw_scale($gd,$scale,$min_score,$max_score,$dx+$self->pad_left,$dy,$y_origin);
   $self->draw_stackedplot($gd,$dx,$dy,$scale,$min_score,$max_score);
#   $self->SUPER::draw($gd,$dx,$dy);
}

sub draw_stackedplot {
  my $self = shift;
  my ($gd,$left,$top,$scale,$min,$max) = @_;

  my $fgcolor = $self->fgcolor;
  my $bgcolor = $self->bgcolor;
  my @colors  = $self->series_colors;
  my @labels  = $self->category_labels;
  my $column_width   = $self->column_width;
  my $column_spacing = $self->column_spacing;
  my $font      = $self->font('gdTinyFont');
  my $fwidth    = $font->width;
  my $fontcolor = $self->fontcolor;

  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);

  # data_series() returns 1 or more values to stack upwards
  # the totals of the values must be no greater than max_score
  if (my $values = $self->data_series) {
    my $x_offset = -$self->pad_left;
    $gd->line($x1+$x_offset,$y2,$x1+$self->pad_left,$y2,$fgcolor);

    for (my $cluster = 0; $cluster < @$values; $cluster++) {
      # this will give us a series of data series
      my $series = $values->[$cluster];
      my $y_offset = 0;
      for (my $i = 0; $i < @$series; $i++) {
	my $value = $series->[$i];
	my $v      = $self->clip($value,$min,$max);	
	my $color  = $colors[$i] || $bgcolor;

	my $y      = $y2 - ($v-$min) * $scale;
	my $box_bottom = $y2 - $y_offset;
	my $box_top    = $y  - $y_offset;
	$self->filled_box($gd,$x1+$x_offset,$box_top,$x1+$column_width+$x_offset,$box_bottom,$color);
	$y_offset += $box_bottom-$box_top;
      }
      if (@labels) {
	my $x = $x1+$x_offset+($column_width-$fwidth*$labels[$cluster])/2-1;
	$gd->string($font,$x,$y2,$labels[$cluster],$fontcolor);
      }
      $x_offset += $column_spacing+$column_width;
    }

  }
}

sub clip {
  my $self = shift;
  my ($value,$min,$max) = @_;
  $value = $min if defined $min && $value < $min;
  $value = $max if defined $max && $value > $max;
  return $value;
}

sub series_colors {
  my $self    = shift;
  my $values  = $self->option('series_colors');
  my @colors;
  if ($values && !ref $values) {
    @colors = split /\s+/,$values;
  } elsif (ref $values eq 'ARRAY') {
    @colors = @$values;
  } else {
    @colors = qw(red blue green orange brown grey black);
  }
  return map {$self->factory->translate_color($_)} @colors;
}

sub category_labels {
  my $self    = shift;
  my $values  = $self->option('category_labels');
  my @labels;
  if ($values && !ref $values) {
    @labels = split /\s+/,$values;
  } elsif (ref $values eq 'ARRAY') {
    @labels = @$values;
  }
  return @labels;
}

# NOTE!
# probably data_series should return this:
# [series1 => [value1,value2,value3,value4],
#  series2 => [value1,value2,value3,value4],
#  series3 => [value1,value2,value3,value4],
#  ...
# ]
sub data_series {
  my $self  = shift;
  my $values = $self->option('series');
  return $values if defined $values;

  # otherwise get it from the feature
  my @values;
  my @tagvalues = $self->feature->get_tag_values('series');
  for my $v (@tagvalues) {
    if (ref $v && ref $v eq 'ARRAY') {  # already in right format
      push @values,$v;
    } else {
      push @values,[split /[,\w]/,$v];
    }
  }
  return \@values;
}

1;

__END__

=head1 NAME

Bio::Graphics::Glyph::stackedplot - The stackedplot glyph

=head1 SYNOPSIS

  See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.

=head1 DESCRIPTION

=head2 OPTIONS

The following options are standard among all Glyphs.  See
L<Bio::Graphics::Glyph> for a full explanation.

  Option      Description                      Default
  ------      -----------                      -------

  -fgcolor      Foreground color	       black

  -outlinecolor	Synonym for -fgcolor

  -bgcolor      Background color               turquoise

  -fillcolor    Synonym for -bgcolor

  -linewidth    Line width                     1

  -height       Height of glyph		       10

  -font         Glyph font		       gdSmallFont

  -label        Whether to draw a label	       0 (false)

  -description  Whether to draw a description  0 (false)

  -hilite       Highlight color                undef (no color)

In addition, the alignment glyph recognizes all the options of the
xyplot glyph, as well as the following glyph-specific option:

  Option         Description                  Default
  ------         -----------                  -------


=head1 EXAMPLES


=back

=head1 BUGS

Please report them.

=head1 SEE ALSO

L<Bio::Graphics::Panel>,
L<Bio::Graphics::Track>,
L<Bio::Graphics::Glyph::transcript2>,
L<Bio::Graphics::Glyph::anchored_arrow>,
L<Bio::Graphics::Glyph::arrow>,
L<Bio::Graphics::Glyph::box>,
L<Bio::Graphics::Glyph::primers>,
L<Bio::Graphics::Glyph::segments>,
L<Bio::Graphics::Glyph::toomany>,
L<Bio::Graphics::Glyph::transcript>,

=head1 AUTHOR

Lincoln Stein E<lt>lstein at cshl.orgE<gt>

Copyright (c) 2006 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut


Index: xyplot.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/Graphics/Glyph/xyplot.pm,v
retrieving revision 1.29
retrieving revision 1.30
diff -C2 -d -r1.29 -r1.30
*** xyplot.pm	14 Dec 2006 21:53:54 -0000	1.29
--- xyplot.pm	20 Dec 2006 23:35:03 -0000	1.30
***************
*** 65,69 ****
  sub draw {
    my $self = shift;
- 
    my ($gd,$dx,$dy) = @_;
    my ($left,$top,$right,$bottom) = $self->calculate_boundaries($dx,$dy);
--- 65,68 ----
***************
*** 107,111 ****
      $_->{_y_position}   = $self->score2position($s);
    }
- 
    my $type           = $self->option('graph_type') || $self->option('graphtype') || 'boxes';
    my (@draw_methods) = $self->lookup_draw_method($type);
--- 106,109 ----
***************
*** 343,352 ****
    my $font  = $self->font('gdTinyFont');
  
!   $gd->line($x1,$y1,$x1,$y2,$fg) if $side eq 'left'  || $side eq 'both';
!   $gd->line($x2,$y1,$x2,$y2,$fg) if $side eq 'right' || $side eq 'both';
  
    $gd->line($x1,$y_origin,$x2,$y_origin,$fg);
  
!   my @points = ([$y1,$max],[($y1+$y2)/2,($min+$max)/2],[$y2,$min]);
    push @points,[$y_origin,0] if ($min < 0 && $max > 0);
  
--- 341,350 ----
    my $font  = $self->font('gdTinyFont');
  
!   $gd->line($x1,$y1,$x1,$y_origin,$fg) if $side eq 'left'  || $side eq 'both';
!   $gd->line($x2,$y1,$x2,$y_origin,$fg) if $side eq 'right' || $side eq 'both';
  
    $gd->line($x1,$y_origin,$x2,$y_origin,$fg);
  
!   my @points = ([$y1,$max],[($y1+$y2)/2,($min+$max)/2],[$y_origin,$min]);
    push @points,[$y_origin,0] if ($min < 0 && $max > 0);
  



More information about the Bioperl-guts-l mailing list