[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