Merge branch 'master' of github.com:bioperl/bioperl-live

bioperl · Mar 14, 2011 · 8a5c827 · 8a5c827
2 parents 117af47 + 52e52e6
commit 8a5c827
Show file tree

Hide file tree

Showing 10 changed files with 36 additions and 33 deletions.
diff --git a/Bio/Assembly/IO/ace.pm b/Bio/Assembly/IO/ace.pm
@@ -313,6 +313,7 @@ sub next_contig {
             my $bs_feat = Bio::SeqFeature::Generic->new(
                 -start   => $start,
                 -end     => $end,
+                -source  => 'ace',
                 -strand  => 1,
                 -primary => '_base_segments',
                 -tag     => { 'contig_id' => $contig_id}
@@ -354,6 +355,7 @@ sub next_contig {
             my $coord = Bio::SeqFeature::Generic->new(
                 -start  => $padded_start,
                 -end    => $padded_end,
+                -source => 'ace',
                 -strand => $read_data->{$read_name}{'strand'},
                 -tag    => { 'contig' => $contigOBJ->id }
             );
@@ -396,7 +398,7 @@ sub next_contig {
                     -end     => $qual_end,
                     -strand  => $read_data->{$read_name}{'strand'},
                     -primary => '_quality_clipping',
-                    -source  => $read_name,
+                    -source  => $read_name || '',
                 );
                 $qual_feat->attach_seq( $contigOBJ->get_seq_by_name($read_name) );
                 $contigOBJ->add_features([ $qual_feat ], 0);
@@ -421,7 +423,7 @@ sub next_contig {
                 -start   => $start,
                 -end     => $end,
                 -primary => '_read_desc', # primary_tag
-                -source  => $read_name,
+                -source  => $read_name || '',
                 -tag     => \%tags
             );
             $contigOBJ->get_features_collection->add_features([$read_desc]);
@@ -442,12 +444,12 @@ sub next_contig {
                 -start   => $start,
                 -end     => $end,
                 -primary => '_read_tags',
-                -source  => $readID,
+                -source  => $readID || '',
                 -tag     => { 'type'          => $type,
                               'source'        => $source,
-                              'creation_date' => $date,
-                              'extra_info'    => $extra_info }
+                              'creation_date' => $date}
             );
+            $read_tag->add_tag_value('extra_info', $extra_info) if defined $extra_info;
             my $contig = $read_data->{$readID}{'contig'};
             my $coord  = $contig->get_seq_coord( $contig->get_seq_by_name($readID) );
             $contig->get_features_collection->add_features([$read_tag]);
@@ -562,6 +564,7 @@ sub scaffold_annotations {
             my $contig_tag = Bio::SeqFeature::Generic->new( -start   => $start,
                                                             -end     => $end,
                                                             -primary => $type,
+                                                            -source  => 'ace',
                                                             -tag     => \%tags );
             my $contig = $assembly->get_contig_by_id($contigID) ||
                          $assembly->get_singlet_by_id($contigID);
@@ -916,7 +919,8 @@ sub _write_read {
         my $type   = ($read_tag->get_tag_values('type')         )[0];
         my $source = ($read_tag->get_tag_values('source')       )[0];
         my $date   = ($read_tag->get_tag_values('creation_date'))[0];
-        my $extra  = ($read_tag->get_tag_values('extra_info')   )[0] || '';
+        my $extra  = $read_tag->has_tag('extra_info') ?
+                ($read_tag->get_tag_values('extra_info')   )[0] : '';
         $self->_print(
             "RT{\n".
             "$read_id $type $source $start $end $date\n".

diff --git a/Bio/Assembly/IO/sam.pm b/Bio/Assembly/IO/sam.pm
@@ -362,7 +362,7 @@ sub _store_contig {
     #    # dumping ground:
     #    -tag         => \%other
     #);
-    $contigobj->add_features([ $contigtags ], 1);
+    #$contigobj->add_features([ $contigtags ], 1);
 
     return $contigobj;
 }

diff --git a/Bio/DB/SeqFeature/Store/memory.pm b/Bio/DB/SeqFeature/Store/memory.pm
@@ -328,7 +328,7 @@ sub _update_name_index {
 sub _update_type_index {
   my ($self, $obj, $id, $del) = @_;
   my $primary_tag = lc($obj->primary_tag) || return;
-  my $source_tag  = lc($obj->source_tag ) || '';
+  my $source_tag  = lc($obj->source_tag || '');
   if (not $del) {
     $self->{_index}{type}{$primary_tag}{$source_tag}{$id} = undef;
   } else {
@@ -475,7 +475,7 @@ sub find_types {
     } else {
       ($primary_tag, undef, $source_tag) = ($type_req =~ m/^(.*?)(:(.*))?$/); 
     }
-    ($primary_tag, $source_tag) = (lc $primary_tag, lc $source_tag);
+    ($primary_tag, $source_tag) = (lc $primary_tag, lc($source_tag || ''));
 
     next if not exists $$types{$primary_tag};
 

diff --git a/Bio/Root/Root.pm b/Bio/Root/Root.pm
@@ -474,7 +474,7 @@ sub throw {
     }
     else {
         $class ||= '';
-        $class = ' '.$class if $class;
+        $class = ': '.$class if $class;
         my $std = $self->stack_trace_dump();
         my $title = "------------- EXCEPTION$class -------------";
         my $footer = ('-' x CORE::length($title))."\n";

diff --git a/Bio/SeqIO/seqxml.pm b/Bio/SeqIO/seqxml.pm
@@ -1085,7 +1085,7 @@ sub DESTROY {
 
 sub close {
     my $self = shift;
-    if ( $self->mode eq 'w' ) {
+    if ( $self->mode eq 'w' && $self->{'_writer'}->within_element('seqXML') ) {
         $self->{'_writer'}->endTag("seqXML");
         $self->{'_writer'}->end();
     }

diff --git a/Bio/Tree/TreeFunctionsI.pm b/Bio/Tree/TreeFunctionsI.pm
@@ -635,10 +635,12 @@ sub force_binary {
 
     my @descs = $node->each_Descendent;
     if (@descs > 2) {
-        $self->warn("Node ".($node->can('node_name') ? ($node->node_name || $node->id) : $node->id).
-                    " has more than two descendants\n(".
-                    join(", ", map { $node->can('node_name') ? ($node->node_name || $node->id || '') : $node->id || '' } @descs).
-                    ")\nWill do an arbitrary balanced split");
+        # Removed overly verbose warning - cjfields 3-12-11
+
+        # Many nodes have no identifying names, a simple warning is probably
+        # enough.
+
+        $self->warn("Node has more than two descendants\nWill do an arbitrary balanced split");
         my @working = @descs;
         # create an even set of artifical nodes on which to later hang the descs
         my $half = @working / 2;

diff --git a/README b/README
@@ -4,7 +4,7 @@ This is the README file for the BioPerl central distribution.
 
 o Version  
 
- This is bioperl-live, from BioPerl Subversion HEAD
+ This is bioperl-live, from the BioPerl GitHub master branch 
 
 o Getting Started
 

diff --git a/t/Map/Map.t b/t/Map/Map.t
@@ -681,7 +681,7 @@ use_ok('Bio::Map::Prediction');
         is $gene->display_id($map1), 'ENSG00000139618';
         is $gene->display_id($map2), 'ENSMUSG00000041147';
         is $gene->display_id($map4), 'ENSGALG00000017073';
-        is $gene->display_xref($map4), 'NP_989607.1';
+        is $gene->display_xref($map4), 'Q8QFV6_CHICK';
         is $gene->external_name($map1), 'BRCA2';
         is $gene->biotype($map2), 'protein_coding';
         is $gene->source($map4), 'ensembl';
@@ -697,8 +697,10 @@ use_ok('Bio::Map::Prediction');
         is length($seq), 84737;
         is substr($seq, 0, 20), 'TGTTACAGAACCAACGAATT'; # start of upstream
         is substr($seq, -20, 20), 'CTACAAGTATTATTTTACAA'; # end of gene since no downstream
-        is substr($map1->subseq($gene->coding_position($map1)), 0, 3), 'ATG';
-        my $exon1_str = 'GGGCTTGTGGCGCGAGCTTCTGAAACTAGGCGGCAGAGGCGGAGCCGCTGTGGCACTGCTGCGCCTCTGCTGCG';
+        is substr($map1->subseq($gene->coding_position($map1)), 0, 3), 'GGG';
+        my $exon1_str = 'GGGCTTGTGGCGCGAGCTTCTGAAACTAGGCGGCAGAGGCGGAGCCGCTGTG'.
+            'GCACTGCTGCGCCTCTGCTGCGCCTCGGGTGTCTTTTGCGGCGGTGGGTCGCCGCCGGGAGAAG'.
+            'CGTGAGGGGACAGA';
         my $exon1_pos = $gene->get_exon_position($map1, 1);
         is $map1->subseq($exon1_pos), $exon1_str;
         is $exon1_pos->seq, $exon1_str;

diff --git a/t/RemoteDB/CUTG.t b/t/RemoteDB/CUTG.t
@@ -62,7 +62,7 @@ SKIP: {
 	$db->verbose($verbose ? $verbose : -1);
 	my $cdtable;
 	eval {$cdtable = $db->get_request(-sp =>'Pan troglodytes');};
-	skip "Server/network problems? Skipping those tests\n$@", 5 if $@;
+	skip "Server/network problems? Skipping those tests\n$@", 9 if $@;
 
 	# tests for Table.pm, the answers seem to change with time, so not specific
 	cmp_ok($cdtable->cds_count(), '>', 10);
@@ -75,7 +75,7 @@ SKIP: {
 	my $db2 = Bio::DB::CUTG->new();
 	$db2->verbose($verbose ? $verbose : -1);
 	eval {$cut2 = $db2->get_request(-sp =>'Wookie magnus');};
-	skip "Server/network problems? Skipping those tests\n$@", 1 if $@;
+	skip "Server/network problems? Skipping those tests\n$@", 5 if $@;
 	is $cut2->species(), 'Homo sapiens';
 
 	$db = Bio::DB::CUTG->new();

diff --git a/t/Root/RootI.t b/t/Root/RootI.t
@@ -16,12 +16,11 @@ BEGIN {
 ok my $obj = Bio::Root::Root->new();
 isa_ok($obj, 'Bio::Root::RootI');
 
-eval { $obj->throw('Testing throw') };
-ok $@ =~ /Testing throw/;# 'throw failed';
+throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'throw failed';
 
 # test throw_not_implemented()
-eval { $obj->throw_not_implemented() };
-ok $@ =~ /EXCEPTION: Bio::Root::NotImplemented/;
+throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION: Bio::Root::NotImplemented/;
+
 {
     package Bio::FooI;
     use base qw(Bio::Root::RootI);
@@ -33,8 +32,7 @@ ok $@ =~ /EXCEPTION: Bio::Root::NotImplemented/;
 	};
 }
 $obj = Bio::FooI->new();
-eval { $obj->throw_not_implemented() };
-ok $@ =~ /EXCEPTION /;
+throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION /;
 $obj = Bio::Root::Root->new();
 
 # doesn't work in perl 5.00405
@@ -53,15 +51,12 @@ $obj = Bio::Root::Root->new();
 #'verbose(0) warn did not work properly' . $val;
 
 $obj->verbose(-1);
-eval { $obj->throw('Testing throw') };
-ok $@=~ /Testing throw/;# 'verbose(-1) throw did not work properly' . $@;
+throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(-1) throw did not work properly' . $@;
 
-eval { $obj->warn('Testing warn') };
-ok !$@;
+lives_ok { $obj->warn('Testing warn') };
 
 $obj->verbose(1);
-eval { $obj->throw('Testing throw') };
-ok $@ =~ /Testing throw/;# 'verbose(1) throw did not work properly' . $@;
+throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(1) throw did not work properly' . $@;
 
 # doesn't work in perl 5.00405
 #undef $val;