Added feature renderer script and squashed a few rendering bugs in

Bio::Graphics.

svn path=/bioperl-live/trunk/; revision=3553

Bio/DB/FileCache.pm

@@ -61,7 +61,6 @@ methods. Internal methods are usually preceded with a _
 
 package Bio::DB::FileCache;
 
-use Bio::DB::SeqI;
 use DB_File;
 use Storable qw(freeze thaw);
 use Fcntl qw(O_CREAT O_RDWR O_RDONLY);
@@ -71,10 +70,16 @@ use vars qw(@ISA);
 use strict;
 
 use Bio::Root::Root;
-use Bio::Seq;
 
 @ISA = qw(Bio::Root::Root Bio::DB::SeqI);
 
+use Bio::DB::SeqI;
+use Bio::Seq::RichSeq;
+use Bio::Location::Split;
+use Bio::Location::Fuzzy;
+use Bio::Seq;
+use Bio::SeqFeature::Generic;
+
 =head2 new
 
  Title   : new
@@ -267,7 +272,8 @@ sub _get {
   my $self = shift;
   my ($type,$id) = @_;
   my $serialized = $self->db->{"${type}_${id}"};
-  return thaw($serialized);
+  my $obj = thaw($serialized);
+  $obj;
 }
 
 sub _store {

Bio/Graphics.pm

@@ -17,8 +17,8 @@ Bio::Graphics - Generate GD images of Bio::Seq objects
 
   use Bio::Graphics;
 
-  # get a set of Bio::SeqFeature objects, in this case from AcePerl
-  use Ace::Sequence;
+  # get a set of Bio::SeqFeature objects ... somehow
+  my $cosmid = Bio::
   my $db     = Ace->connect(-host=>'brie2.cshl.org',-port=>2005) or die;
   my $cosmid = Ace::Sequence->new(-seq=>'Y16B4A',
 				  -db=>$db,-start=>-15000,-end=>15000) or die;

Bio/Graphics/Feature.pm

@@ -81,11 +81,31 @@ sub add_segment {
   }
   if (@segments) {
     $self->{segments} = [ sort {$a->start <=> $b->start } @segments ];
-    $self->{start} = $self->{segments}[0]->start;
-    ($self->{stop}) = sort { $b <=> $a } map { $_->end} @segments;
+    $self->{start}    = $self->{segments}[0]->start;
+    ($self->{stop})   = sort { $b <=> $a } map { $_->end } @segments;
   }
 }
 
+sub location {
+  my $self = shift;
+
+  require Bio::Location::Split;
+  my @segments = $self->segments;
+  if (@segments) {
+    my $split = Bio::Location::Split->new;
+    foreach (@segments) {
+      $split->add_sub_Location(Bio::Location::Simple->new(-start  => $_->start,
+							  -end    => $_->end,
+							  -strand => $_->strand
+							 ));
+    }
+    return $split;
+  }
+  return Bio::Location::Simple->new(-start  => $self->start,
+				    -end    => $self->end,
+				    -strand => $self->strand);
+}
+
 sub segments {
   my $self = shift;
   my $s = $self->{segments} or return wantarray ? () : 0;

Bio/Graphics/Glyph.pm

@@ -37,10 +37,10 @@ sub new {
   }
 
   if (defined $self->start && defined $self->stop) {
-      my ($left,$right) = $factory->map_pt($self->start,$self->stop);
-      ($left,$right) = ($right,$left) if $left > $right;  # paranoia
-      $self->{left}    = $left;
-      $self->{width}   = $right - $left + 1;
+    my ($left,$right) = $factory->map_pt($self->start,$self->stop);
+    ($left,$right) = ($right,$left) if $left > $right;  # paranoia
+    $self->{left}    = $left;
+    $self->{width}   = $right - $left + 1;
   }
   if (@subglyphs) {
       my $l            = $subglyphs[0]->left;
@@ -439,9 +439,8 @@ sub draw {
   local($self->{partno},$self->{total_parts});
   @{$self}{qw(partno total_parts)} = ($partno,$total_parts);
 
-  $self->layout;
+  my $connector =  $self->connector;
   if (my @parts = $self->parts) {
-    my $connector =  $self->connector;
     my $x = $left;
     my $y = $top  + $self->top + $self->pad_top;
 
@@ -450,13 +449,17 @@ sub draw {
       # lie just a little bit to avoid lines overlapping and
       # make the picture prettier
       my $fake_x = $x;
-      $fake_x-- if defined $last_x && $parts[$i]->left - $last_x <= 1;
+      $fake_x-- if defined $last_x && $parts[$i]->left - $last_x == 1;
       $parts[$i]->draw($gd,$fake_x,$y,$i,scalar(@parts));
       $last_x = $parts[$i]->right;
     }
     $self->draw_connectors($gd,$x,$y) if $connector && $connector ne 'none';
-  } else {  # no part
+  }
+
+  else {  # no part
     $self->draw_component($gd,$left,$top);
+    $self->draw_connectors($gd,$left,$top)
+      if $connector && $connector ne 'none' && $self->feature->isa('Bio::SeqFeatureI');
   }
 }
 
@@ -469,7 +472,7 @@ sub draw_connectors {
     $self->_connector($gd,$dx,$dy,$parts[$i]->bounds,$parts[$i+1]->bounds);
   }
 
-  if (1) { # this is working, but it's a bit awkward
+  if (0) { # this is commented out until I remember what it does
     my($x1,$y1,$x2,$y2) = $self->bounds(0,0);
     my($xl,$xt,$xr,$xb) = $parts[0]->bounds;
     $self->_connector($gd,$dx,$dy,$x1,$xt,$x1,$xb,$xl,$xt,$xr,$xb);
@@ -631,6 +634,7 @@ sub filled_arrow {
   my $orientation = shift;
 
   my ($x1,$y1,$x2,$y2) = @_;
+
   my ($width) = $gd->getBounds;
   my $indent = $y2-$y1 < $x2-$x1 ? $y2-$y1 : ($x2-$x1)/2;
 
@@ -702,12 +706,27 @@ sub draw_component {
   }
 }
 
+# memoize _subseq -- it's a bottleneck with segments
 sub subseq {
-  my $class = shift;
+  my $self    = shift;
+  my $feature = shift;
+  return $self->_subseq($feature) unless ref $self;
+  return @{$self->{cached_subseq}{$feature}} if $self->{cached_subseq}{$feature};
+  my @ss = $self->_subseq($feature);
+  $self->{cached_subseq}{$feature} = \@ss;
+  @ss;
+}
+
+sub _subseq {
+  my $class   = shift;
   my $feature = shift;
-  return $feature->merged_segments if $feature->can('merged_segments');
-  return $feature->segments        if $feature->can('segments');
-  return $feature->sub_SeqFeature  if $feature->can('sub_SeqFeature');
+  return $feature->merged_segments         if $feature->can('merged_segments');
+  return $feature->segments                if $feature->can('segments');
+  my @split = eval { my $id = $feature->location->seq_id;
+		     my @subs = $feature->location->sub_Location;
+		     grep {$id eq $_->seq_id} $feature->location->sub_Location};
+  return @split if @split;
+  return $feature->sub_SeqFeature          if $feature->can('sub_SeqFeature');
   return;
 }
 

Bio/Graphics/Glyph/Factory.pm

@@ -13,7 +13,6 @@ my %GENERIC_OPTIONS = (
 		       height     => 8,
 		       font       => gdSmallFont,
 		       bump       => +1,       # bump by default (perhaps a mistake?)
-		       connector  => 'none',
 		       );
 
 sub new {
@@ -64,6 +63,8 @@ sub translate_color {
 sub make_glyph {
   my $self = shift;
   my @result;
+  my $panel = $self->panel;
+  my ($leftmost,$rightmost) = ($panel->left,$panel->right);
 
   for my $f (@_) {
 
@@ -76,8 +77,12 @@ sub make_glyph {
       carp("the requested glyph class, ``$type'' is not available: $@")
 	unless (eval "require $glyphclass");
     }
-    push @result, $glyphclass->new(-feature  => $f,
-				   -factory  => $self);
+    my $glyph = $glyphclass->new(-feature  => $f,
+				 -factory  => $self);
+
+    # this is removing glyphs that are not onscreen at all (but not tracks)
+    push @result,$glyph if $type eq 'track' 
+      || ($glyph->{left} + $glyph->{width} >= $leftmost && $glyph->{left} <= $rightmost);
   }
   return wantarray ? @result : $result[0];
 }
@@ -116,6 +121,7 @@ sub option {
     if (defined(my $value  = $map->{$option_name})) {
       my $feature = $glyph->feature;
       return $value unless ref $value eq 'CODE';
+      return unless $feature->isa('Bio::SeqFeatureI');
       my $val = $value->($feature,$option_name,$partno,$total_parts);
       return defined $val && $val eq '*default*' ? $GENERIC_OPTIONS{$option_name} : $val;
     }

Bio/Graphics/Glyph/generic.pm

@@ -58,14 +58,13 @@ sub _label {
   my $label = $self->option('label');
   return unless defined $label;
   return $label unless $label eq '1';
-  return "1"    if $label eq '1 ';
+  return "1"    if $label eq '1 '; # 1 with a space
 
   # figure it out ourselves
   my $f = $self->feature;
   my $info = eval {$f->info};
   return $info if $info;
-  return $f->seqname if $f->can('seqname');
-  return $f->primary_tag;
+  return eval {$f->seqname} || eval{$f->primary_tag};
 }
 sub _description {
   my $self = shift;
@@ -158,6 +157,7 @@ sub arrow {
   my $self = shift;
   my $gd   = shift;
   my ($x1,$x2,$y) = @_;
+
   my $fg     = $self->set_pen;
   my $height = $self->height/3;
 

Bio/Graphics/Glyph/group.pm

@@ -12,6 +12,9 @@ sub connector {
   return 'dashed' unless $self->SUPER::connector eq 'none';
 }
 
+# we don't label group (yet)
+sub label { 0 }
+
 #sub layout_width {
 #  my $self = shift;
 #  my @parts = $self->parts or return $self->SUPER::layout_width;

Bio/Graphics/Glyph/segments.pm

@@ -4,8 +4,9 @@ use strict;
 use Bio::Graphics::Glyph::generic;
 use Bio::Graphics::Glyph::segmented_keyglyph;
 use vars '@ISA';
-@ISA = qw(Bio::Graphics::Glyph::segmented_keyglyph
-	  Bio::Graphics::Glyph::generic);
+@ISA = qw( Bio::Graphics::Glyph::segmented_keyglyph
+	   Bio::Graphics::Glyph::generic
+	 );
 
 #sub pad_right {
 #  my $self = shift;
@@ -17,25 +18,25 @@ use vars '@ISA';
 sub connector {
   my $self = shift;
   return $self->SUPER::connector(@_) if $self->all_callbacks;
-  return return $self->SUPER::connector(@_) || 'solid';
+  return $self->SUPER::connector(@_) || 'solid';
 }
 # group sets connector to 'solid'
 sub bump {
   my $self = shift;
   return $self->SUPER::bump(@_) if $self->all_callbacks;
   return 0;
 }
-# turn off labels
 sub label {
   my $self = shift;
-  return unless (my @a = $self->feature->sub_SeqFeature) > 0;
-  $self->SUPER::label(@_);
+  return $self->SUPER::label(@_) if $self->all_callbacks || $self->feature->isa('Bio::SeqFeatureI');
+  return unless $self->subseq($self->feature);
+  return $self->SUPER::label(@_);
 }
-# turn off and descriptions
 sub description {
   my $self = shift;
-  return unless (my @a = $self->feature->sub_SeqFeature) > 0;
-  $self->SUPER::description(@_);
+  return $self->SUPER::description(@_) if $self->all_callbacks || $self->feature->isa('Bio::SeqFeatureI');
+  return unless $self->subseq($self->feature);
+  return $self->SUPER::description(@_);
 }
 
 1;

Bio/Graphics/Glyph/transcript.pm

@@ -4,8 +4,9 @@ use strict;
 use Bio::Graphics::Glyph::generic;
 use Bio::Graphics::Glyph::segmented_keyglyph;
 use vars '@ISA';
-@ISA = qw(Bio::Graphics::Glyph::segmented_keyglyph
-	  Bio::Graphics::Glyph::generic);
+@ISA = qw( Bio::Graphics::Glyph::segmented_keyglyph
+	   Bio::Graphics::Glyph::generic
+	 );
 
 sub pad_left  {
   my $self = shift;
@@ -27,6 +28,7 @@ sub draw_connectors {
   my ($left,$top) = @_;
   $self->SUPER::draw_connectors($gd,$left,$top);
   my @parts = $self->parts;
+  @parts = $self unless @parts;
   if ($self->feature->strand >= 0) {
     my($x1,$y1,$x2,$y2) = $parts[-1]->bounds(@_);
     my $center = ($y2+$y1)/2;
@@ -58,14 +60,14 @@ sub bump {
 
 sub label {
   my $self = shift;
-  return $self->SUPER::label(@_) if $self->all_callbacks;
-  return 0 unless $self->feature->sub_SeqFeature;
+  return $self->SUPER::label(@_) if $self->all_callbacks || $self->feature->isa('Bio::SeqFeatureI');
+  return unless $self->subseq($self->feature);
   return $self->SUPER::label(@_);
 }
 sub description {
   my $self = shift;
-  return $self->SUPER::description(@_) if $self->all_callbacks;
-  return 0 unless $self->feature->sub_SeqFeature;
+  return $self->SUPER::description(@_) if $self->all_callbacks || $self->feature->isa('Bio::SeqFeatureI');
+  return unless $self->subseq($self->feature);
   return $self->SUPER::description(@_);
 }
 

Bio/Graphics/Glyph/transcript2.pm

@@ -38,11 +38,16 @@ sub draw_component {
   my $filled = defined($self->{partno}) && $width >= MIN_WIDTH_FOR_ARROW;
 
   if ($filled) {
+    my $f = $self->feature;
 
-    if ($self->feature->strand < 0 && $self->{partno} == 0) { # first exon, minus strand transcript
+    if ($f->strand < 0 && 
+	($f->isa('Bio::SeqFeatureI')
+	 || $self->{partno} == 0)) { # first exon, minus strand transcript
       $self->filled_arrow($gd,-1,@rect);
       $self->{filled}++;
-    } elsif ($self->feature->strand >= 0 && $self->{partno} == $self->{total_parts}-1) { # last exon, plus strand
+    } elsif ($f->strand >= 0 
+	     && ($f->isa('Bio::SeqFeatureI') 
+		 || $self->{partno} == $self->{total_parts}-1)) { # last exon, plus strand
       $self->filled_arrow($gd,+1,@rect);
       $self->{filled}++;
     } else {
@@ -71,19 +76,6 @@ sub draw_connectors {
   }
 }
 
-sub label {
-  my $self = shift;
-  return $self->SUPER::label(@_) if $self->all_callbacks;
-  return 0 unless $self->feature->sub_SeqFeature;
-  return $self->SUPER::label(@_);
-}
-sub description {
-  my $self = shift;
-  return $self->SUPER::description(@_) if $self->all_callbacks;
-  return 0 unless $self->feature->sub_SeqFeature;
-  return $self->SUPER::description(@_);
-}
-
 sub bump {
   my $self = shift;
   return $self->SUPER::bump(@_) if $self->all_callbacks;