[Bioperl-guts-l] [14982] bioperl-live/trunk/Bio: migrated glyphs from gbrowse distribution into bioperl main

Lincoln Stein lstein at dev.open-bio.org
Tue Nov 11 11:03:46 EST 2008


Revision: 14982
Author:   lstein
Date:     2008-11-11 11:03:45 -0500 (Tue, 11 Nov 2008)

Log Message:
-----------
migrated glyphs from gbrowse distribution into bioperl main

Modified Paths:
--------------
    bioperl-live/trunk/Bio/DB/SeqFeature/Store/berkeleydb.pm
    bioperl-live/trunk/Bio/DB/SeqFeature/Store.pm
    bioperl-live/trunk/Bio/Graphics/Panel.pm

Added Paths:
-----------
    bioperl-live/trunk/Bio/Graphics/Glyph/phylo_align.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/smoothing.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/spectrogram.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/trace.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/wiggle_box.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/wiggle_density.pm
    bioperl-live/trunk/Bio/Graphics/Glyph/wiggle_xyplot.pm
    bioperl-live/trunk/Bio/Graphics/Wiggle.pm

Modified: bioperl-live/trunk/Bio/DB/SeqFeature/Store/berkeleydb.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/SeqFeature/Store/berkeleydb.pm	2008-11-10 13:21:03 UTC (rev 14981)
+++ bioperl-live/trunk/Bio/DB/SeqFeature/Store/berkeleydb.pm	2008-11-11 16:03:45 UTC (rev 14982)
@@ -139,7 +139,7 @@
 new_feature() repeatedly, you can create the database and then bulk
 populate it using the GFF3 loader, or you can monitor a directory of
 preexisting GFF3 and FASTA files and rebuild the indexes whenever one
-or more of the fiels changes. The last mode is probably the most
+or more of the fields changes. The last mode is probably the most
 convenient.
 
 =over 4
@@ -447,7 +447,7 @@
   for my $obj (@_) {
     my $primary_id = $obj->primary_id;
     $self->_delete_indexes($obj,$primary_id)  if $indexed && $primary_id;
-    $primary_id    = $db->{'.next_id'}++ unless defined $primary_id;
+    $primary_id    = $db->{'.next_id'}++      unless defined $primary_id;
     $db->{$primary_id} = $self->freeze($obj);
     $obj->primary_id($primary_id);
     $self->_update_indexes($obj)              if $indexed;
@@ -459,6 +459,8 @@
 sub _delete_indexes {
   my $self = shift;
   my ($obj,$id) = @_;
+  warn $obj->display_name;
+
   # the additional "1" causes the index to be deleted
   $self->_update_name_index($obj,$id,1);
   $self->_update_type_index($obj,$id,1);

Modified: bioperl-live/trunk/Bio/DB/SeqFeature/Store.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/SeqFeature/Store.pm	2008-11-10 13:21:03 UTC (rev 14981)
+++ bioperl-live/trunk/Bio/DB/SeqFeature/Store.pm	2008-11-11 16:03:45 UTC (rev 14982)
@@ -240,6 +240,9 @@
 *get_SeqFeatures = \&fetch_SeqFeatures;
 *delete_SeqFeatures = *delete_features = \&delete;
 
+# local version
+sub api_version { 1.2 }
+
 =head1 Methods for Connecting and Initializating a Database
 
 =head2 new

Added: bioperl-live/trunk/Bio/Graphics/Glyph/phylo_align.pm
===================================================================
--- bioperl-live/trunk/Bio/Graphics/Glyph/phylo_align.pm	                        (rev 0)
+++ bioperl-live/trunk/Bio/Graphics/Glyph/phylo_align.pm	2008-11-11 16:03:45 UTC (rev 14982)
@@ -0,0 +1,1231 @@
+package Bio::Graphics::Glyph::phylo_align;
+
+use strict;
+use base qw(Bio::Graphics::Glyph::generic Bio::Graphics::Glyph::xyplot);
+use Bio::TreeIO;
+use Bio::Graphics::Wiggle;
+use POSIX qw(log10);
+
+use Carp 'croak','cluck';
+use Data::Dumper;
+
+my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',n=>'n',
+		  G=>'C',A=>'T',T=>'A',C=>'G',N=>'N');
+
+
+# turn off description
+sub description { 0 }
+
+# turn off label
+# sub label { 1 }
+
+sub height {
+  my $self = shift;
+  my $font = $self->font;
+  
+  #adjust the space to take if conservation scores are drawn instead
+  if (! $self->dna_fits) {
+    my $species_spacing_score = $self->option('species_spacing_score') || 5;
+    $self->factory->set_option('species_spacing', $species_spacing_score);
+  }
+  
+  my $species_spacing = $self->option('species_spacing') || 1;
+  
+  #Height = NumSpecies x Spacing/species x FontHeight
+  my $height = ($self->known_species + $self->unknown_species + 1)
+            * $species_spacing
+            * $font->height;
+  
+  #use this if you want to show only those species that have alignments in the viewing window
+  #$height = ($self->extract_features + 1) * 2 * $font->height;
+  
+  $self->factory->set_option('height', $height);
+  
+  
+  return $height;
+  
+}
+
+#####
+# TODO: extract the wigfiles covering the range as well
+#####
+# get all features within the viewing window
+sub extract_features {
+  my $self = shift;
+  #my $segment = $self->feature->{'factory'}->segment($self->feature->refseq,
+  #						      $self->feature->start => $self->feature->stop);
+  #my @match = $segment->features('submatch:pa'); 
+  my @match = $self->feature->features('submatch:pa');
+#print "Match has ",$#match,"<p>\n";
+  
+  # exract wifiles here too:
+  my @wmatch = $self->feature->features('wfile:pa');
+  #push @match, $self->feature->features('wfile:pa');
+#  print "xxxxxx<pre>",Dumper(@wmatch),"</pre>cccccc";
+#print "WMatch has ",$#wmatch,"<p>\n";
+
+#print "Halfwaypoint<p>";  
+#for my $feature (@match, at wmatch) {
+#my %attributes = $feature->attributes;
+#my $species = $attributes{'species'};
+#print "<pre>Feature $species:\n",Dumper(%attributes),"</pre>\n";
+#}
+
+  my %alignments;
+#  for my $feature (@match) {
+  for my $feature (@match, at wmatch) {
+    my %attributes = $feature->attributes;
+    my $species = $attributes{'species'};
+    
+    push @{$alignments{$species}}, $feature;
+  }
+  
+  %alignments;
+}
+
+#known species (all those that are in the Phylo tree)
+sub known_species {
+  my $self = shift;
+  
+  my $tree = shift;
+  
+  if ($tree) {
+    my @leaves = $tree->get_leaf_nodes;
+    my @allspecies = map {$_->id} @leaves;
+    return @allspecies
+    
+  } else {
+    #this may be too simple of an assumption, especially for non newick files
+    my $tree_file = $self->option('tree_file');
+    
+    open (FH, $tree_file);
+    my $newick = <FH>;
+    close FH;
+    
+    my @allspecies = $newick =~ /([a-zA-Z]\w*)/g;
+    return @allspecies;
+  }
+}
+
+sub unknown_species {
+  my $self = shift;
+
+  my %alignments;        #all species in viewing window
+  my $refspecies;        #all species from cladogram info
+  my @current_species;   #all species in viewing window
+  my @known_species;     #species in GFF but and clado
+  my @unknown_species;   #species in GFF but not in clado
+  # current - known = unknown
+  
+  
+  if (@_) {
+    %alignments = %{$_[0]};
+    $refspecies = $_[1];
+    @current_species = @{$_[2]};
+    @known_species = @{$_[3]};
+    @unknown_species;
+  } else {
+    %alignments = $self->extract_features;
+    $refspecies = $self->option('reference');
+    @current_species =  keys %alignments;   #all species in viewing window
+    @known_species = $self->known_species;  #all species from cladogram info
+    @unknown_species;                       #species in GFF but not in clado
+  } #would have combined the two cases into one line using || but Perl will treat the arrays as num of elem
+  
+  #do set subtraction to see which species in viewing range but not in tree
+  my %seen;  # build lookup table
+  @seen{@known_species} = ();
+  foreach my $item (@current_species, $refspecies) {
+    push(@unknown_species, $item) unless exists $seen{$item};
+  }
+  
+  return @unknown_species;
+  
+}
+
+sub set_tree {
+  my $self = shift;
+  
+  #warn"My species are ".Dumper(@species);
+  
+  my $tree_file   = $self->option('tree_file');
+  my $tree_format = $self->option('tree_format') || 'newick';
+  
+  my $treeio = new Bio::TreeIO(-file   => $tree_file,
+                               -format => $tree_format);
+  
+  
+  
+  my $tree = $treeio->next_tree;
+  my $root = $tree->get_root_node;
+  
+  # would be ideal to remove all species that don't have features (alignments) within
+  # viewing window but there is a bug in Bio::Tree library where you can't remove the
+  # first leaf node.
+  
+  #  $tree->remove_Node('dog'); # etc...
+  
+  #set the leaf x coodinate (make all evenly spaced)
+  my @leaves = $tree->get_leaf_nodes;
+  for (my $i=0; $i<@leaves; $i++) {
+    my $leaf = $leaves[$i];
+  
+    #note that leaves can use "description" functions while intermediate nodes cannot
+    #thus objects must be handled directly
+    $leaf->description({'x'=>$i});
+  
+  }
+  
+  
+  #set root height to 0
+  $root->{'description'}{'y'} = 0;
+  
+  #set the x and y coordinates of all intermediate nodes
+  get_n_set_next_treenode($root, 0);
+  
+  flip_xy($tree);
+
+  
+  $tree;
+  
+}
+
+sub get_max_height {
+  my $tree = shift;
+  my $max_height;
+  
+  #get the max height
+  for my $child ($tree->get_leaf_nodes) {
+    my $x = $child->{'_description'}{'x'};
+    $max_height = $x if $max_height < $x;
+  }
+  
+  $max_height;
+}
+
+
+sub draw_clado {
+  my $self = shift;
+  my $tree = shift;
+  my $gd = shift;
+  my ($x1, $y1, $x2, $y2, $color, $xscale, $yscale, $xoffset, $yoffset, $start_x, $draw_clado_left) = @_;
+  
+  my @bounds = $gd->getBounds;
+  
+  my $root = $tree->get_root_node;
+  my @nodes = $root->get_all_Descendents;
+  
+  #draw bg for cladogram
+  my $clado_bg = $self->color('clado_bg') || $self->bgcolor;
+  my @coords = (0, $y1, $start_x+$xoffset+$self->font->width-1, $y2+1);
+  my @coords2 = ($x1, $y1, $start_x+$xoffset/2, $y2);
+  if ($draw_clado_left) {
+    $gd->filledRectangle(@coords, $clado_bg);
+    $gd->filledRectangle(@coords2, $self->color('clado_bg'));
+    $gd->filledRectangle($x2, $x1, $bounds[0], $bounds[1], $self->color('bg_color')) if $self->dna_fits;
+  } else {
+    $gd->filledRectangle($bounds[0]-$coords[2], $coords[1], $bounds[0]-$coords[0], $coords[3],
+  			 $self->color('bg_color'));
+    $gd->filledRectangle($bounds[0]-$coords2[2], $coords2[1], $bounds[0]-$coords2[0], $coords2[3],
+			 $clado_bg);  
+    $gd->filledRectangle(0, $y1, $x1, $y2+1, $self->color('bg_color')) if $self->dna_fits;
+  }
+
+  
+  
+  #draw the lines of the tree
+  for my $node ($root, at nodes) {
+    next if $node->is_Leaf;
+    my $x = $node->{'_description'}{'x'} * $xscale;
+    
+    #draw vertical line covering all children
+    my $topx = $node->{'_description'}{'childmin'} * $yscale;
+    my $botx = $node->{'_description'}{'childmax'} * $yscale;
+    
+    @coords = ($x+$xoffset, $topx+$yoffset, $x+$xoffset, $botx+$yoffset);
+    if ($draw_clado_left) {
+      $gd->line(@coords, $self->fgcolor);
+    } else {
+      $gd->line($bounds[0]-$coords[2], $coords[1], $bounds[0]-$coords[0], $coords[3], $self->fgcolor);
+    }
+    
+    #draw a line connecting the bar to each child
+    my @children = $node->each_Descendent;
+    for my $child (@children) {
+      my $cx = $child->{'_description'}{'x'} * $xscale;
+      my $cy = $child->{'_description'}{'y'} * $yscale;
+      $cx = $start_x if $child->is_Leaf;
+      
+      #print"($cx, $cy)";
+      
+      @coords = ($x+$xoffset, $cy+$yoffset, $cx+$xoffset, $cy+$yoffset);
+      if ($draw_clado_left) {
+        $gd->line(@coords, $self->fgcolor);
+      } else {

@@ Diff output truncated at 10000 characters. @@



More information about the Bioperl-guts-l mailing list