From bugzilla-daemon at portal.open-bio.org Mon Sep 1 02:18:57 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 1 Sep 2008 02:18:57 -0400
Subject: [Bioperl-guts-l] [Bug 2577] Bio::Assembly and Bio::Assembly::IO can
exceed the set open file ulimit
In-Reply-To:
Message-ID: <200809010618.m816IvMI010746@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2577
cjfields at bioperl.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|NEW |RESOLVED
Resolution| |FIXED
------- Comment #3 from cjfields at bioperl.org 2008-09-01 02:18 EST -------
(In reply to comment #2)
> SeqFeature::Collection could also be replaced with Bio::DB::SeqFeature::Store
> which can handle in-memory or flatfile berkeleydb and intends to handle
> multiple coordinate systems at the same time?
I think anything that is Bio::SeqFeature::CollectionI should work (though we
probably could define more abstract methods in the interface, such as a
remove_features).
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Mon Sep 1 02:24:24 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 1 Sep 2008 02:24:24 -0400
Subject: [Bioperl-guts-l] [Bug 2577] Bio::Assembly and Bio::Assembly::IO can
exceed the set open file ulimit
In-Reply-To:
Message-ID: <200809010624.m816OOp4010995@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2577
cjfields at bioperl.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|RESOLVED |REOPENED
Resolution|FIXED |
------- Comment #4 from cjfields at bioperl.org 2008-09-01 02:24 EST -------
Um, don't know how that happened, but that wasn't supposed to be closed.
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From jason at dev.open-bio.org Mon Sep 1 02:59:40 2008
From: jason at dev.open-bio.org (Jason Stajich)
Date: Mon, 1 Sep 2008 02:59:40 -0400
Subject: [Bioperl-guts-l] [14841] bioperl-ext/trunk/Bio/Ext/Align/libs:
include errno definition
Message-ID: <200809010659.m816xeeg015583@dev.open-bio.org>
Revision: 14841
Author: jason
Date: 2008-09-01 02:59:39 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
include errno definition
Modified Paths:
--------------
bioperl-ext/trunk/Bio/Ext/Align/libs/makefile
bioperl-ext/trunk/Bio/Ext/Align/libs/wisefile.h
Modified: bioperl-ext/trunk/Bio/Ext/Align/libs/makefile
===================================================================
--- bioperl-ext/trunk/Bio/Ext/Align/libs/makefile 2008-08-29 16:45:38 UTC (rev 14840)
+++ bioperl-ext/trunk/Bio/Ext/Align/libs/makefile 2008-09-01 06:59:39 UTC (rev 14841)
@@ -1,6 +1,3 @@
-
-
-
OBJS = aln.o\
alnconvert.o\
alnrange.o\
Modified: bioperl-ext/trunk/Bio/Ext/Align/libs/wisefile.h
===================================================================
--- bioperl-ext/trunk/Bio/Ext/Align/libs/wisefile.h 2008-08-29 16:45:38 UTC (rev 14840)
+++ bioperl-ext/trunk/Bio/Ext/Align/libs/wisefile.h 2008-09-01 06:59:39 UTC (rev 14841)
@@ -14,6 +14,7 @@
#ifdef NOERROR
#define ERRORSTR "No error available"
#else
+#include
#define ERRORSTR strerror(errno)
#endif
From jason at dev.open-bio.org Mon Sep 1 03:00:50 2008
From: jason at dev.open-bio.org (Jason Stajich)
Date: Mon, 1 Sep 2008 03:00:50 -0400
Subject: [Bioperl-guts-l] [14842]
bioperl-ext/trunk/Bio/Ext/Align/libs/makefile: -fPIC needed for lib
construction
Message-ID: <200809010700.m8170owR015615@dev.open-bio.org>
Revision: 14842
Author: jason
Date: 2008-09-01 03:00:50 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
-fPIC needed for lib construction
Modified Paths:
--------------
bioperl-ext/trunk/Bio/Ext/Align/libs/makefile
Modified: bioperl-ext/trunk/Bio/Ext/Align/libs/makefile
===================================================================
--- bioperl-ext/trunk/Bio/Ext/Align/libs/makefile 2008-09-01 06:59:39 UTC (rev 14841)
+++ bioperl-ext/trunk/Bio/Ext/Align/libs/makefile 2008-09-01 07:00:50 UTC (rev 14842)
@@ -46,5 +46,5 @@
# For NetBSD or Sun (solaris) installs, add -fPIC to the CFLAGS lines
#
-CFLAGS = -c -O
+CFLAGS = -c -O -fPIC
CC = cc
From jason at dev.open-bio.org Mon Sep 1 03:44:25 2008
From: jason at dev.open-bio.org (Jason Stajich)
Date: Mon, 1 Sep 2008 03:44:25 -0400
Subject: [Bioperl-guts-l] [14843] bioperl-ext/trunk/Bio/Ext/Align/libs/sw.h:
get rid of some unended comment warnings from C compiler
Message-ID: <200809010744.m817iPEH016293@dev.open-bio.org>
Revision: 14843
Author: jason
Date: 2008-09-01 03:44:25 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
get rid of some unended comment warnings from C compiler
Modified Paths:
--------------
bioperl-ext/trunk/Bio/Ext/Align/libs/sw.h
Modified: bioperl-ext/trunk/Bio/Ext/Align/libs/sw.h
===================================================================
--- bioperl-ext/trunk/Bio/Ext/Align/libs/sw.h 2008-09-01 07:00:50 UTC (rev 14842)
+++ bioperl-ext/trunk/Bio/Ext/Align/libs/sw.h 2008-09-01 07:44:25 UTC (rev 14843)
@@ -1353,12 +1353,11 @@
*
* bp_sw_change_max_BaseMatrix_kbytes
* bp_sw_get_max_BaseMatrix_kbytes
- *
+ */
-
-/* These functions are not associated with an object */
-/* Function: bp_sw_change_max_BaseMatrix_kbytes(new_kilo_number)
+/* These functions are not associated with an object
+ * Function: bp_sw_change_max_BaseMatrix_kbytes(new_kilo_number)
*
* Descrip: This is to change, at run-time the maximum level of bytes basematrix *thinks*
* it can use. This number is *not* used for any actual calls to basematrix
@@ -1589,9 +1588,8 @@
* bp_sw_new_cDNADB_from_single_seq
* bp_sw_new_cDNADB
*
-
-/* API for object cDNADB */
-/* Function: bp_sw_get_cDNA_from_cDNADB(cdnadb,de)
+ * API for object cDNADB
+ * Function: bp_sw_get_cDNA_from_cDNADB(cdnadb,de)
*
* Descrip: Gets cDNA sequence out from
* the cDNADB using the information stored in
@@ -1895,10 +1893,10 @@
* bp_sw_base_from_char
* bp_sw_char_complement_base
* bp_sw_complement_base
- *
+ */
-/* API for object CodonTable */
-/* Function: bp_sw_read_CodonTable_file(file)
+/* API for object CodonTable
+ * Function: bp_sw_read_CodonTable_file(file)
*
* Descrip: Opens filename, reads it as if a Ewan style
* codon table and closes.
@@ -2241,7 +2239,7 @@
/* Helper functions in the module
*
* bp_sw_flat_CodonMapper
- *
+ */
/* API for object CodonMapper */
/* Function: bp_sw_sprinkle_errors_over_CodonMapper(cm,error)
@@ -3328,7 +3326,7 @@
*
* bp_sw_new_GenomicDB_from_single_seq
* bp_sw_new_GenomicDB
- *
+ */
/* API for object GenomicDB */
/* Function: bp_sw_get_Genomic_from_GenomicDB(gendb,de)
@@ -3848,7 +3846,7 @@
/* Helper functions in the module
*
* bp_sw_new_Histogram
- *
+ */
/* API for object Histogram */
/* Function: bp_sw_UnfitHistogram(h)
@@ -4813,7 +4811,7 @@
* bp_sw_Score2Probability
* bp_sw_Score2Bits
* bp_sw_halfbit2Probability
- *
+ */
@@ -5022,7 +5020,7 @@
* bp_sw_new_ProteinDB_from_single_seq
* bp_sw_single_fasta_ProteinDB
* bp_sw_new_ProteinDB
- *
+ */
/* API for object ProteinDB */
/* Function: bp_sw_hard_link_ProteinDB(obj)
@@ -5220,10 +5218,9 @@
* bp_sw_write_pretty_str_align
* bp_sw_write_pretty_seq_align
* bp_sw_write_pretty_Protein_align
- *
+ */
-
/* These functions are not associated with an object */
/* Function: bp_sw_write_pretty_str_align(alb,qname,query,tname,target,name,main,ofp)
*
@@ -5326,7 +5323,7 @@
*
* bp_sw_Sequence_type_to_string
* bp_sw_new_Sequence_from_strings
- *
+ */
/* API for object Sequence */
/* Function: bp_sw_uppercase_Sequence(seq)
@@ -6301,10 +6298,8 @@
* bp_sw_Align_strings_ProteinSmithWaterman
* bp_sw_Align_Sequences_ProteinSmithWaterman
* bp_sw_Align_Proteins_SmithWaterman
- *
+ */
-
-
/* These functions are not associated with an object */
/* Function: bp_sw_Align_strings_ProteinSmithWaterman(one,two,comp,gap,ext)
*
From lapp at dev.open-bio.org Mon Sep 1 23:54:27 2008
From: lapp at dev.open-bio.org (Hilmar Lapp)
Date: Mon, 1 Sep 2008 23:54:27 -0400
Subject: [Bioperl-guts-l] [14844] bioperl-db/trunk/Bio/DB/BioSQL/OBDA.pm:
Fixed to use placeholders and a named query, rather than doing the quoting
Message-ID: <200809020354.m823sRgw019934@dev.open-bio.org>
Revision: 14844
Author: lapp
Date: 2008-09-01 23:54:26 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
Fixed to use placeholders and a named query, rather than doing the quoting
itself (which would have also been a security hole if the parameter came from
user or web form input). This also gets rid of the incompatibility with
PostgreSQL v8.3+!
Modified Paths:
--------------
bioperl-db/trunk/Bio/DB/BioSQL/OBDA.pm
Modified: bioperl-db/trunk/Bio/DB/BioSQL/OBDA.pm
===================================================================
--- bioperl-db/trunk/Bio/DB/BioSQL/OBDA.pm 2008-09-01 07:44:25 UTC (rev 14843)
+++ bioperl-db/trunk/Bio/DB/BioSQL/OBDA.pm 2008-09-02 03:54:26 UTC (rev 14844)
@@ -113,22 +113,27 @@
=cut
sub get_Seq_by_id {
- my ($self,$id) = @_;
- my $db = $self->_db;
- my @seqs = ();
- $self->throw("No identifier given") unless $id;
-
- my $query = Bio::DB::Query::BioQuery->new(
- -datacollections => ['Bio::SeqI seq'],
- -where => ["seq.primary_id = $id"]);
-
- my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
- my $result = $seq_adaptor->find_by_query($query);
-
- for my $seq ($result->next_object) {
- push @seqs,$seq;
- }
- return wantarray ? @seqs : $seqs[0];
+ my ($self,$id) = @_;
+ my $db = $self->_db;
+ my @seqs = ();
+ $self->throw("No identifier given") unless $id;
+
+ my $query = $self->{'_byId_Query'};
+ if (! $query) {
+ $query = Bio::DB::Query::BioQuery->new(
+ -datacollections => ['Bio::SeqI seq'],
+ -where => ["seq.primary_id = ?"]);
+ $self->{'_byId_Query'} = $query;
+ }
+ my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
+ my $result = $seq_adaptor->find_by_query($query,
+ '-name' => 'OBDA get_Seq_by_id',
+ '-values' => [$id]);
+
+ for my $seq ($result->next_object) {
+ push @seqs,$seq;
+ }
+ return wantarray ? @seqs : $seqs[0];
}
=head2 get_Seq_by_acc
@@ -143,22 +148,27 @@
=cut
sub get_Seq_by_acc {
- my ($self,$acc) = @_;
- my $db = $self->_db;
- my @seqs = ();
- $self->throw("No accession given") unless $acc;
+ my ($self,$acc) = @_;
+ my $db = $self->_db;
+ my @seqs = ();
+ $self->throw("No accession given") unless $acc;
- my $query = Bio::DB::Query::BioQuery->new(
- -datacollections => ['Bio::SeqI seq'],
- -where => ["seq.accession_number = '$acc'"]);
+ my $query = $self->{'_byAcc_Query'};
+ if (! $query) {
+ $query = Bio::DB::Query::BioQuery->new(
+ -datacollections => ['Bio::SeqI seq'],
+ -where => ["seq.accession_number = ?"]);
+ $self->{'_byAcc_Query'} = $query;
+ }
+ my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
+ my $result = $seq_adaptor->find_by_query($query,
+ '-name' => "OBDA get_Seq_by_acc",
+ '-values' => [$acc]);
- my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
- my $result = $seq_adaptor->find_by_query($query);
-
- for my $seq ($result->next_object) {
- push @seqs,$seq;
- }
- return wantarray ? @seqs : $seqs[0];
+ for my $seq ($result->next_object) {
+ push @seqs,$seq;
+ }
+ return wantarray ? @seqs : $seqs[0];
}
=head2 get_Seq_by_version
@@ -173,25 +183,32 @@
=cut
sub get_Seq_by_version {
- my ($self,$vacc) = @_;
- my $db = $self->_db;
- my @seqs = ();
- my ($acc,$ver) = split /\./, $vacc; # split on period
- $self->throw("Must supply a versioned accession: .")
- unless ($acc && $ver);
-
- my $query = Bio::DB::Query::BioQuery->new(
- -datacollections => ['Bio::SeqI seq'],
- -where => ["seq.accession_number = '$acc'",
- "seq.version = $ver"]);
-
- my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
- my $result = $seq_adaptor->find_by_query($query);
-
- for my $seq ($result->next_object) {
- push @seqs,$seq;
- }
- return wantarray ? @seqs : $seqs[0];
+ my ($self,$vacc) = @_;
+ my $db = $self->_db;
+ my @seqs = ();
+ my @comps = split(/\./, $vacc); # split into components on period
+ $self->throw("Must supply a versioned accession: .")
+ unless @comps >= 2;
+ my $ver = pop(@comps); # the last one is the version
+ my $acc = join(".", at comps); # the preceding rest is the accession
+
+ my $query = $self->{'_byAccVersion_Query'};
+ if (! $query) {
+ $query = Bio::DB::Query::BioQuery->new(
+ -datacollections => ['Bio::SeqI seq'],
+ -where => ["seq.accession_number = ?",
+ "seq.version = ?"]);
+ $self->{'_byAccVersion_Query'} = $query;
+ }
+ my $seq_adaptor = $db->get_object_adaptor('Bio::SeqI');
+ my $result = $seq_adaptor->find_by_query($query,
+ '-name' => "OBDA get_Seq_by_version",
+ '-values' => [$acc,$ver]);
+
+ for my $seq ($result->next_object) {
+ push @seqs,$seq;
+ }
+ return wantarray ? @seqs : $seqs[0];
}
=head1 Private methods
From lapp at dev.open-bio.org Mon Sep 1 23:55:27 2008
From: lapp at dev.open-bio.org (Hilmar Lapp)
Date: Mon, 1 Sep 2008 23:55:27 -0400
Subject: [Bioperl-guts-l] [14845] bioperl-db/trunk/t/16obda.t: Mostly
cosmetic change in how the config file is written to silence a warning .
Message-ID: <200809020355.m823tRLA019962@dev.open-bio.org>
Revision: 14845
Author: lapp
Date: 2008-09-01 23:55:27 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
Mostly cosmetic change in how the config file is written to silence a warning.
Modified Paths:
--------------
bioperl-db/trunk/t/16obda.t
Modified: bioperl-db/trunk/t/16obda.t
===================================================================
--- bioperl-db/trunk/t/16obda.t 2008-09-02 03:54:26 UTC (rev 14844)
+++ bioperl-db/trunk/t/16obda.t 2008-09-02 03:55:27 UTC (rev 14845)
@@ -78,9 +78,11 @@
my $file = shift;
my $c = $db->dbcontext;
my ($host,$port,$dbname,$pass,$user,$driver) =
- ($c->host,$c->port,$c->dbname,$c->password,$c->username,$c->driver);
+ ($c->host||'',$c->port||'',$c->dbname||'',$c->password||'',$c->username||'',$c->driver||'');
- my $text = "VERSION=1.00
+ open F,">$file";
+ print F <$file";
- print F $text;
- close F;
+OBDA
+ close F;
}
From lapp at dev.open-bio.org Mon Sep 1 23:56:46 2008
From: lapp at dev.open-bio.org (Hilmar Lapp)
Date: Mon, 1 Sep 2008 23:56:46 -0400
Subject: [Bioperl-guts-l] [14846] bioperl-db/trunk/Bio/DB/DBI: Migrated code
to capabilities of more modern DBI and DBD versions.
Message-ID: <200809020356.m823ukBx019988@dev.open-bio.org>
Revision: 14846
Author: lapp
Date: 2008-09-01 23:56:46 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
Migrated code to capabilities of more modern DBI and DBD versions.
Modified Paths:
--------------
bioperl-db/trunk/Bio/DB/DBI/Pg.pm
bioperl-db/trunk/Bio/DB/DBI/mysql.pm
Modified: bioperl-db/trunk/Bio/DB/DBI/Pg.pm
===================================================================
--- bioperl-db/trunk/Bio/DB/DBI/Pg.pm 2008-09-02 03:55:27 UTC (rev 14845)
+++ bioperl-db/trunk/Bio/DB/DBI/Pg.pm 2008-09-02 03:56:46 UTC (rev 14846)
@@ -130,11 +130,15 @@
}
# we need to construct the sql statement
$seq = $self->sequence_name() unless $seq;
- my $row = $dbh->selectrow_arrayref("SELECT nextval('$seq')");
+ # use a cached (prepared) statement for this, and if for any
+ # reason it is still active when we request it, it fill be
+ # finish()ed first.
+ my $sth = $dbh->prepare_cached("SELECT nextval('$seq')", undef, 1);
+ my $row = $dbh->selectrow_arrayref($sth);
my $dbid;
- if(! ($row && @$row && ($dbid = $row->[0]))) {
- $self->throw("no record inserted or wrong database handle -- ".
- "probably internal error");
+ if (! ($row && ($dbid = $row->[0]))) {
+ $self->throw("Does sequence '$seq' exist? -- ".
+ "Probably internal error: ".$sth->errstr);
}
return $dbid;
}
@@ -169,11 +173,15 @@
}
# we need to construct the sql statement
$seq = $self->sequence_name() unless $seq;
- my $row = $dbh->selectrow_arrayref("SELECT currval('$seq')");
+ # use a cached (prepared) statement for this, and if for any
+ # reason it is still active when we request it, it fill be
+ # finish()ed first.
+ my $sth = $dbh->prepare_cached("SELECT currval('$seq')", undef, 1);
+ my $row = $dbh->selectrow_arrayref($sth);
my $dbid;
- if(! ($row && @$row && ($dbid = $row->[0]))) {
+ if (! ($row && ($dbid = $row->[0]))) {
$self->throw("no record inserted or wrong database handle -- ".
- "probably internal error");
+ "probably internal error: ".$sth->errstr);
}
return $dbid;
}
Modified: bioperl-db/trunk/Bio/DB/DBI/mysql.pm
===================================================================
--- bioperl-db/trunk/Bio/DB/DBI/mysql.pm 2008-09-02 03:55:27 UTC (rev 14845)
+++ bioperl-db/trunk/Bio/DB/DBI/mysql.pm 2008-09-02 03:56:46 UTC (rev 14846)
@@ -153,16 +153,7 @@
$self->throw("no database handle supplied to last_id_value() --".
"last_id and currval operations are connection-specific");
}
- my $sth = $dbh->prepare("SELECT last_insert_id()");
- my $dbid;
- if($sth->execute()) {
- my $row = $sth->fetchrow_arrayref();
- if(! ($row && @$row && ($dbid = $row->[0]))) {
- $self->throw("no record inserted or wrong database handle -- ".
- "probably internal error");
- }
- }
- return $dbid;
+ return $dbh->{'mysql_insertid'};
}
=head2 ifnull_sqlfunc
From lapp at dev.open-bio.org Mon Sep 1 23:58:02 2008
From: lapp at dev.open-bio.org (Hilmar Lapp)
Date: Mon, 1 Sep 2008 23:58:02 -0400
Subject: [Bioperl-guts-l] [14847]
bioperl-db/trunk/Bio/DB/BioSQL/BasePersistenceAdaptor.pm: Made sure that
the persistence driver's prepare() and bind_param() front-ends
Message-ID: <200809020358.m823w2JL020013@dev.open-bio.org>
Revision: 14847
Author: lapp
Date: 2008-09-01 23:58:02 -0400 (Mon, 01 Sep 2008)
Log Message:
-----------
Made sure that the persistence driver's prepare() and bind_param() front-ends
are actually being used.
Modified Paths:
--------------
bioperl-db/trunk/Bio/DB/BioSQL/BasePersistenceAdaptor.pm
Modified: bioperl-db/trunk/Bio/DB/BioSQL/BasePersistenceAdaptor.pm
===================================================================
--- bioperl-db/trunk/Bio/DB/BioSQL/BasePersistenceAdaptor.pm 2008-09-02 03:56:46 UTC (rev 14846)
+++ bioperl-db/trunk/Bio/DB/BioSQL/BasePersistenceAdaptor.pm 2008-09-02 03:58:02 UTC (rev 14847)
@@ -393,6 +393,9 @@
"::add_assoc: ".
"binding column $i to \"".$obj->primary_key().
"\" (FK to ".ref($obj->obj()).")\n");
+ # we cheat a few microseconds here by not routing the call
+ # through the persistence driver, but there really shouldn't
+ # be any special treatment needed for primary keys
$sth->bind_param($i, $obj->primary_key());
$i++;
}
@@ -409,7 +412,7 @@
"::add_assoc: ".
"binding column $i to \"",
$values->{$valkey}, "\" ($valkey)\n");
- $sth->bind_param($i, $values->{$valkey});
+ $dbd->bind_param($sth, $i, $values->{$valkey});
$i++;
}
}
@@ -514,6 +517,9 @@
"::remove_assoc: ".
"binding column $i to \"".$obj->primary_key().
"\" (FK to ".ref($obj->obj()).")\n");
+ # we cheat a few microseconds here by not routing the call
+ # through the persistence driver, but there really shouldn't
+ # be any special treatment needed for primary keys
$sth->bind_param($i, $obj->primary_key());
$i++;
}
@@ -530,7 +536,7 @@
"::remove_assoc: ".
"binding column $i to \"",
$values->{$valkey}, "\" ($valkey)\n");
- $sth->bind_param($i, $values->{$valkey});
+ $dbd->bind_param($sth, $i, $values->{$valkey});
$i++;
}
}
@@ -936,9 +942,10 @@
": binding UK column ".(++$i)." to \"".$query_h->{$_}."\" ($_)\n";
} keys %$query_h));
}
+ my $dbd = $self->dbd();
$i = 0;
foreach (keys %$query_h) {
- $sth->bind_param(++$i, $query_h->{$_});
+ $dbd->bind_param($sth, ++$i, $query_h->{$_});
}
# execute and check for error
if(! $sth->execute()) {
@@ -1086,7 +1093,7 @@
my $sql = $sqlgen->generate_sql($tquery);
# prepare statement
$self->debug("preparing SELECT ASSOC query: $sql\n");
- $sth = $self->dbh()->prepare($sql);
+ $sth = $self->dbd->prepare($self->dbh(), $sql);
# and cache for future use
$self->sth($cache_key, $sth);
}
@@ -1100,6 +1107,9 @@
$obj->primary_key().
"\" (FK to ".ref($obj->obj()).")\n");
}
+ # we cheat a few microseconds here by not routing the call
+ # through the persistence driver, but there really shouldn't
+ # be any special treatment needed for primary keys
$sth->bind_param($i, $obj->primary_key());
$i++;
}
@@ -1112,7 +1122,7 @@
$values->{$constraint}.
"\" (constraint ".$constraint->name.")\n");
}
- $sth->bind_param($i, $values->{$constraint});
+ $self->dbd->bind_param($sth, $i, $values->{$constraint});
$i++;
}
# execute
@@ -1167,7 +1177,7 @@
objects for resulting rows
-name a unique name for the query, which will make
- the the statement be a cached prepared
+ the statement be a cached prepared
statement, which in subsequent invocations
will only be re-bound with parameters values,
but not recreated
@@ -1208,7 +1218,7 @@
my $sql = $sqlgen->generate_sql($query);
# prepare
$self->debug("preparing query: $sql\n");
- if($sth = $self->dbh()->prepare($sql)) {
+ if($sth = $self->dbd->prepare($self->dbh(), $sql)) {
# cache if named query
$self->sth($qname, $sth) if $qname;
} else {
@@ -1221,12 +1231,13 @@
}
# bind parameter values if any and if a named query
if($qname && $qvalues && @$qvalues) {
+ my $dbd = $self->dbd();
for(my $i = 1; $i <= @$qvalues; $i++) {
$self->debug("Query $qname: binding column $i to \"".
$qvalues->[$i-1]."\"\n");
# We generally don't want to raise an exception.
my $rv;
- eval { $rv = $sth->bind_param($i, $qvalues->[$i-1]); };
+ eval { $rv = $dbd->bind_param($sth, $i, $qvalues->[$i-1]); };
if(! $rv) {
# This is either due to an internal bug or to a constraint
# column not supported by the underlying schema (i.e., mapped
From lapp at dev.open-bio.org Tue Sep 2 00:00:39 2008
From: lapp at dev.open-bio.org (Hilmar Lapp)
Date: Tue, 2 Sep 2008 00:00:39 -0400
Subject: [Bioperl-guts-l] [14848] bioperl-db/trunk/t/03simpleseq.t: Added
test for inserting, updating, and constraining char columns using numeric
Message-ID: <200809020400.m8240dCp020038@dev.open-bio.org>
Revision: 14848
Author: lapp
Date: 2008-09-02 00:00:39 -0400 (Tue, 02 Sep 2008)
Log Message:
-----------
Added test for inserting, updating, and constraining char columns using numeric
values (which can be an issue in PostgreSQL v8.3+).
Modified Paths:
--------------
bioperl-db/trunk/t/03simpleseq.t
Modified: bioperl-db/trunk/t/03simpleseq.t
===================================================================
--- bioperl-db/trunk/t/03simpleseq.t 2008-09-02 03:58:02 UTC (rev 14847)
+++ bioperl-db/trunk/t/03simpleseq.t 2008-09-02 04:00:39 UTC (rev 14848)
@@ -9,12 +9,13 @@
# as a fallback
eval { require Test; };
use Test;
- plan tests => 59;
+ plan tests => 67;
}
use DBTestHarness;
use Bio::SeqIO;
use Bio::Root::IO;
+use Bio::PrimarySeq;
$biosql = DBTestHarness->new("biosql");
$db = $biosql->get_DBAdaptor();
@@ -40,7 +41,7 @@
$seqio->close();
$seqio = Bio::SeqIO->new('-format' => 'fasta',
'-file' =>
- Bio::Root::IO->catfile('t','data','Titin.fasta') );
+ Bio::Root::IO->catfile('t','data','Titin.fasta') );
my $lseq = $seqio->next_seq();
$seqio->close();
$lseq->namespace("mytestnamespace");
@@ -83,7 +84,8 @@
my $sequk = Bio::PrimarySeq->new(
-accession_number => $pseq->accession_number(),
-namespace => $pseq->namespace());
- $dbseq = $db->get_object_adaptor($sequk)->find_by_unique_key($sequk);
+ my $adp2 = $db->get_object_adaptor($sequk);
+ $dbseq = $adp2->find_by_unique_key($sequk);
ok $dbseq;
ok ($dbseq->primary_key, $pseq->primary_key());
@@ -91,7 +93,7 @@
$sequk = Bio::PrimarySeq->new(-accession_number =>$lseq->accession_number,
-version => $lseq->version,
-namespace => $lseq->namespace);
- $dbseq = $db->get_object_adaptor($sequk)->find_by_unique_key($sequk);
+ $dbseq = $adp2->find_by_unique_key($sequk);
ok $dbseq;
ok ($dbseq->accession_number, $lseq->accession_number);
ok ($dbseq->length, $lseq->length);
@@ -107,7 +109,7 @@
$sequk = Bio::PrimarySeq->new(-accession_number =>$lseq->accession_number,
-version => $lseq->version() + 1,
-namespace => $lseq->namespace);
- $dbseq = $db->get_object_adaptor($sequk)->find_by_unique_key($sequk);
+ $dbseq = $adp2->find_by_unique_key($sequk);
ok ($dbseq->length, $lseq->length);
ok ($dbseq->version, $lseq->version() + 1);
ok ($dbseq->subseq(40100,40400), $lseq->subseq(40100,40400));
@@ -119,7 +121,7 @@
$sequk = Bio::PrimarySeq->new(-accession_number =>$lseq->accession_number,
-version => $lseq->version() + 1,
-namespace => $lseq->namespace);
- $dbseq = $db->get_object_adaptor($sequk)->find_by_unique_key($sequk);
+ $dbseq = $adp2->find_by_unique_key($sequk);
ok ($dbseq->length, $lseq->length);
ok ($dbseq->version, $lseq->version() + 1);
ok ($dbseq->subseq(40100,40400), $lseq->subseq(40100,40400));
@@ -139,19 +141,45 @@
$sequk = Bio::PrimarySeq->new(-accession_number =>$lseq->accession_number,
-version => $lseq->version() + 1,
-namespace => $lseq->namespace);
- $dbseq = $db->get_object_adaptor($sequk)->find_by_unique_key($sequk);
+ $dbseq = $adp2->find_by_unique_key($sequk);
ok ($dbseq->length, $lseq->length);
ok ($dbseq->version, $lseq->version() + 1);
ok ($dbseq->subseq(40100,40400), $lseq->subseq(40100,40400));
ok ($dbseq->seq, $lseq->seq);
- # remove the long sequence ...
- ok $plseq->remove;
+ # test automatic casting of numeric values to string (varchar) -
+ # this may be an issue with PostgreSQL v8.3+ (but shouldn't be)
+ my $nseq = Bio::PrimarySeq->new(-accession_number => 123456,
+ -primary_id => 654321,
+ -display_id => 3457,
+ -desc => "test only",
+ -seq => "ACGTACGATGCTAGTAGCATCG",
+ -namespace => $lseq->namespace());
+ my $pnseq = $db->create_persistent($nseq);
+ # insert:
+ $pnseq->create();
+ ok $pnseq->primary_key;
+ # update:
+ $pnseq->primary_id(987654);
+ $pnseq->store();
+ # select (and test for update effect):
+ $sequk = Bio::PrimarySeq->new(-accession_number => 123456,
+ -namespace => $lseq->namespace());
+ $dbseq = $adp2->find_by_unique_key($sequk);
+ ok ($dbseq);
+ ok ($dbseq->accession_number, 123456);
+ ok ($dbseq->primary_id, 987654);
+ ok ($dbseq->display_id, 3457);
+ ok ($dbseq->desc, "test only");
+ ok ($dbseq->seq, "ACGTACGATGCTAGTAGCATCG");
+ # and delete again
+ ok ($dbseq->remove(), 1);
};
print STDERR $@ if $@;
-# delete seq and namespace
+# delete seqs and namespace
+ok ($plseq->remove(), 1);
ok ($pseq->remove(), 1);
my $ns = Bio::DB::Persistent::BioNamespace->new(-identifiable => $pseq);
ok $ns = $db->get_object_adaptor($ns)->find_by_unique_key($ns);
From miraceti at dev.open-bio.org Tue Sep 2 18:37:58 2008
From: miraceti at dev.open-bio.org (miraceti at dev.open-bio.org)
Date: Tue, 2 Sep 2008 18:37:58 -0400
Subject: [Bioperl-guts-l] [14849] bioperl-live/trunk: testing translation
between nhx and phyloxml
Message-ID: <200809022237.m82MbwGm023785@dev.open-bio.org>
Revision: 14849
Author: miraceti
Date: 2008-09-02 18:37:57 -0400 (Tue, 02 Sep 2008)
Log Message:
-----------
testing translation between nhx and phyloxml
Modified Paths:
--------------
bioperl-live/trunk/Bio/TreeIO/phyloxml.pm
bioperl-live/trunk/t/phyloxml.t
Modified: bioperl-live/trunk/Bio/TreeIO/phyloxml.pm
===================================================================
--- bioperl-live/trunk/Bio/TreeIO/phyloxml.pm 2008-09-02 04:00:39 UTC (rev 14848)
+++ bioperl-live/trunk/Bio/TreeIO/phyloxml.pm 2008-09-02 22:37:57 UTC (rev 14849)
@@ -180,7 +180,12 @@
}
$self->_print($attr_str);
$self->_print(">");
- $self->_print($self->_write_tree_Helper($root));
+ if ($root->isa('Bio::Tree::AnnotatableNode')) {
+ $self->_print($self->_write_tree_Helper_annotatableNode($root));
+ }
+ else {
+ $self->_print($self->_write_tree_Helper_generic($root));
+ }
# print clade relations
while (my $str = pop (@{$self->{'_tree_attr'}->{'clade_relation'}})) {
@@ -198,12 +203,10 @@
}
-sub _write_tree_Helper
+sub _write_tree_Helper_annotatableNode
{
my ($self, $node, $str) = @_; # this self is a Bio::Tree::phyloxml
- if (ref($node) ne 'Bio::Tree::AnnotatableNode') {
- $self->throw( "node must be a Bio::Tree::AnnotatableNode" );
- }
+
my $ac = $node->annotation;
# if clade_relation exists
@@ -217,17 +220,17 @@
# start
$str .= 'get_Annotations('_attr'); # check id_source
- if ($attr) {
- my ($id_source) = $attr->get_Annotations('id_source');
- if ($id_source) {
- $str .= " id_source=\"".$id_source->value."\"";
+ if ($attr) {
+ my ($id_source) = $attr->get_Annotations('id_source');
+ if ($id_source) {
+ $str .= " id_source=\"".$id_source->value."\"";
+ }
}
- }
$str .= ">";
# print all descendent nodes
foreach my $child ( $node->each_Descendent() ) {
- $str = $self->_write_tree_Helper($child, $str);
+ $str = $self->_write_tree_Helper_annotatableNode($child, $str);
}
# print all annotations
@@ -246,7 +249,51 @@
$str = print_seq_annotation( $node, $str, $seq );
}
}
+
+ $str .= "";
+
+ return $str;
+}
+
+sub _write_tree_Helper_generic
+{
+ my ($self, $node, $str) = @_; # this self is a Bio::Tree::phyloxml
+ # start
+ $str .= '';
+
+ # print all descendent nodes
+ foreach my $child ( $node->each_Descendent() ) {
+ $str = $self->_write_tree_Helper_generic($child, $str);
+ }
+
+ # print all tags
+ my @tags = $node->get_all_tags();
+ foreach my $tag (@tags) {
+ my @values = $node->get_tag_values($tag);
+ foreach my $val (@values) {
+ $str .= " ";
+ $str .= " ";
+ }
+ }
+
+ # print NodeI features
+ if ($node->id) {
+ $str .= "";
+ $str .= $node->id;
+ $str .= "";
+ }
+ elsif ($node->branch_length) {
+ $str .= "";
+ $str .= $node->branch_length;
+ $str .= "";
+ }
+ elsif ($node->bootstrap) {
+ $str .= "";
+ $str .= $node->bootstrap;
+ $str .= "";
+ }
+
$str .= "";
return $str;
}
@@ -1075,7 +1122,7 @@
foreach my $ann (@all_anns) {
my $key = $ann->tagname;
if ($key eq '_attr') { next; } # attributes are already printed in the previous level
- if (ref($ann) eq 'Bio::Annotation::SimpleValue')
+ if ($ann->isa('Bio::Annotation::SimpleValue'))
{
if ($key eq '_text') {
$str .= $ann->value;
@@ -1086,7 +1133,7 @@
$str .= "";
}
}
- elsif (ref($ann) eq 'Bio::Annotation::Collection')
+ elsif ($ann->isa('Bio::Annotation::Collection'))
{
my @attrs = $ann->get_Annotations('_attr');
if (@attrs) { # if there is a attribute collection
@@ -1109,7 +1156,7 @@
my ($self, $str, $ac) = @_;
my @all_attrs = $ac->get_Annotations();
foreach my $attr (@all_attrs) {
- if (ref($attr) ne 'Bio::Annotation::SimpleValue') {
+ if (!$attr->isa('Bio::Annotation::SimpleValue')) {
$self->throw("attribute should be a SimpleValue");
}
$str .= ' ';
@@ -1138,7 +1185,7 @@
foreach my $ann (@all_anns) {
my $key = $ann->tagname;
if ($key eq '_attr') { next; } # attributes are already printed in the previous level
- if (ref($ann) eq 'Bio::Annotation::SimpleValue')
+ if ($ann->isa('Bio::Annotation::SimpleValue'))
{
if ($key eq '_text') {
$str .= $ann->value;
@@ -1149,7 +1196,7 @@
$str .= "";
}
}
- elsif (ref($ann) eq 'Bio::Annotation::Collection')
+ elsif ($ann->isa('Bio::Annotation::Collection'))
{
my @attrs = $ann->get_Annotations('_attr');
if (@attrs) { # if there is a attribute collection
Modified: bioperl-live/trunk/t/phyloxml.t
===================================================================
--- bioperl-live/trunk/t/phyloxml.t 2008-09-02 04:00:39 UTC (rev 14848)
+++ bioperl-live/trunk/t/phyloxml.t 2008-09-02 22:37:57 UTC (rev 14849)
@@ -7,7 +7,7 @@
use lib 't/lib';
use BioperlTest;
- test_begin(-tests => 90,
+ test_begin(-tests => 93,
-requires_modules => [qw(XML::LibXML XML::LibXML::Reader)],
);
if (1000*$] < 5008) {
@@ -642,3 +642,24 @@
}
+# convert between nhx-phyloxml
+{
+ if ($verbose > 0) {
+ diag("\n test translation between nhx and phyloxml");
+ }
+ ok my $nhxio = Bio::TreeIO->new(
+ -verbose => $verbose,
+ -format => 'nhx',
+ -file => test_input_file('test.nhx'));
+ my $tree = $nhxio->next_tree;
+ isa_ok($tree, 'Bio::Tree::TreeI');
+ my $FILE1 = test_output_file();
+ my $phyloxmlio = Bio::TreeIO->new(-verbose => $verbose,
+ -format => 'phyloxml',
+ -file => ">$FILE1");
+ $phyloxmlio->write_tree($tree);
+ ok -s $FILE1;
+ if ($verbose > 0) {
+ diag(`cat $FILE1`);
+ }
+}
From hartzell at dev.open-bio.org Wed Sep 3 18:54:07 2008
From: hartzell at dev.open-bio.org (George Hartzell)
Date: Wed, 3 Sep 2008 18:54:07 -0400
Subject: [Bioperl-guts-l] [14850]
bioperl-live/trunk/Bio/Coordinate/Result.pm: small documentation fix
Message-ID: <200809032254.m83Ms7Js026204@dev.open-bio.org>
Revision: 14850
Author: hartzell
Date: 2008-09-03 18:54:05 -0400 (Wed, 03 Sep 2008)
Log Message:
-----------
small documentation fix
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/Result.pm
Modified: bioperl-live/trunk/Bio/Coordinate/Result.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/Result.pm 2008-09-02 22:37:57 UTC (rev 14849)
+++ bioperl-live/trunk/Bio/Coordinate/Result.pm 2008-09-03 22:54:05 UTC (rev 14850)
@@ -26,7 +26,7 @@
The results from Bio::Coordinate::MapperI are kept in an object which
itself is a split location, See L. The results
are either Matches or Gaps. See L and
-L.
+L.
If only one Match is returned, there is a convenience method of
retrieving it or accessing its methods. Same holds true for a Gap.
From hartzell at dev.open-bio.org Wed Sep 3 18:57:54 2008
From: hartzell at dev.open-bio.org (George Hartzell)
Date: Wed, 3 Sep 2008 18:57:54 -0400
Subject: [Bioperl-guts-l] [14851]
bioperl-live/trunk/Bio/Coordinate/ExtrapolatingPair.pm: small documentation
typo fix
Message-ID: <200809032257.m83Mvsh2026229@dev.open-bio.org>
Revision: 14851
Author: hartzell
Date: 2008-09-03 18:57:54 -0400 (Wed, 03 Sep 2008)
Log Message:
-----------
small documentation typo fix
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/ExtrapolatingPair.pm
Modified: bioperl-live/trunk/Bio/Coordinate/ExtrapolatingPair.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/ExtrapolatingPair.pm 2008-09-03 22:54:05 UTC (rev 14850)
+++ bioperl-live/trunk/Bio/Coordinate/ExtrapolatingPair.pm 2008-09-03 22:57:54 UTC (rev 14851)
@@ -46,7 +46,7 @@
consistency, and map continuous and split locations from one
coordinate system to another.
-This class is an elaboration of Bio::Coordoinate::Pair. The map
+This class is an elaboration of Bio::Coordinate::Pair. The map
function returns only matches which is the mode needed most of
tehtime. By default the matching regions between coordinate systems
are boundless, so that you can say e.g. that gene starts from here in
From hartzell at dev.open-bio.org Wed Sep 3 19:00:27 2008
From: hartzell at dev.open-bio.org (George Hartzell)
Date: Wed, 3 Sep 2008 19:00:27 -0400
Subject: [Bioperl-guts-l] [14852]
bioperl-live/trunk/Bio/Coordinate/Graph.pm: small documentation typo fix
Message-ID: <200809032300.m83N0Rvx026254@dev.open-bio.org>
Revision: 14852
Author: hartzell
Date: 2008-09-03 19:00:27 -0400 (Wed, 03 Sep 2008)
Log Message:
-----------
small documentation typo fix
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/Graph.pm
Modified: bioperl-live/trunk/Bio/Coordinate/Graph.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 22:57:54 UTC (rev 14851)
+++ bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 23:00:27 UTC (rev 14852)
@@ -60,7 +60,7 @@
algorithm is fast and greedy and requires all weights to be
positive. All weights in the gene coordinate system graph are
currently equal (1) making the graph unweighted. That makes the use of
-Dijkstra's algorithm an overkill. A impler and faster breadth-first
+Dijkstra's algorithm an overkill. A simpler and faster breadth-first
would be enough. Luckily the difference for small graphs is not
signigicant and the implementation is capable to take weights into
account if needed at some later time.
From hartzell at dev.open-bio.org Wed Sep 3 19:01:55 2008
From: hartzell at dev.open-bio.org (George Hartzell)
Date: Wed, 3 Sep 2008 19:01:55 -0400
Subject: [Bioperl-guts-l] [14853]
bioperl-live/trunk/Bio/Coordinate/Graph.pm: small documentation typo and
grammar fix
Message-ID: <200809032301.m83N1tP1026281@dev.open-bio.org>
Revision: 14853
Author: hartzell
Date: 2008-09-03 19:01:55 -0400 (Wed, 03 Sep 2008)
Log Message:
-----------
small documentation typo and grammar fix
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/Graph.pm
Modified: bioperl-live/trunk/Bio/Coordinate/Graph.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 23:00:27 UTC (rev 14852)
+++ bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 23:01:55 UTC (rev 14853)
@@ -62,7 +62,7 @@
currently equal (1) making the graph unweighted. That makes the use of
Dijkstra's algorithm an overkill. A simpler and faster breadth-first
would be enough. Luckily the difference for small graphs is not
-signigicant and the implementation is capable to take weights into
+significant and the implementation is capable of taking weights into
account if needed at some later time.
=head2 Input format
From hartzell at dev.open-bio.org Wed Sep 3 19:02:54 2008
From: hartzell at dev.open-bio.org (George Hartzell)
Date: Wed, 3 Sep 2008 19:02:54 -0400
Subject: [Bioperl-guts-l] [14854]
bioperl-live/trunk/Bio/Coordinate/Graph.pm: small documentation typo fix
Message-ID: <200809032302.m83N2s1M026306@dev.open-bio.org>
Revision: 14854
Author: hartzell
Date: 2008-09-03 19:02:53 -0400 (Wed, 03 Sep 2008)
Log Message:
-----------
small documentation typo fix
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/Graph.pm
Modified: bioperl-live/trunk/Bio/Coordinate/Graph.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 23:01:55 UTC (rev 14853)
+++ bioperl-live/trunk/Bio/Coordinate/Graph.pm 2008-09-03 23:02:53 UTC (rev 14854)
@@ -93,7 +93,7 @@
};
-Note that the names need to be positive integrers. Root should be '1'
+Note that the names need to be positive integers. Root should be '1'
and directness of the graph is taken advantage of to speed
calculations by assuming that downsream nodes always have larger
number as name.
From heikki at dev.open-bio.org Thu Sep 4 02:13:58 2008
From: heikki at dev.open-bio.org (Heikki Lehvaslaiho)
Date: Thu, 4 Sep 2008 02:13:58 -0400
Subject: [Bioperl-guts-l] [14855] bioperl-live/trunk/Bio/Coordinate/Pair.pm:
remove a spurious line creating an unneeded object
Message-ID: <200809040613.m846Dwqr026778@dev.open-bio.org>
Revision: 14855
Author: heikki
Date: 2008-09-04 02:13:58 -0400 (Thu, 04 Sep 2008)
Log Message:
-----------
remove a spurious line creating an unneeded object
Modified Paths:
--------------
bioperl-live/trunk/Bio/Coordinate/Pair.pm
Modified: bioperl-live/trunk/Bio/Coordinate/Pair.pm
===================================================================
--- bioperl-live/trunk/Bio/Coordinate/Pair.pm 2008-09-03 23:02:53 UTC (rev 14854)
+++ bioperl-live/trunk/Bio/Coordinate/Pair.pm 2008-09-04 06:13:58 UTC (rev 14855)
@@ -245,7 +245,6 @@
if ($value->isa("Bio::Location::SplitLocationI")) {
my $result = Bio::Coordinate::Result->new();
- my $split = Bio::Location::Split->new(-seq_id=>$self->out->seq_id);
foreach my $loc ( $value->sub_Location(1) ) {
my $res = $self->_map($loc);
map { $result->add_sub_Location($_) } $res->each_Location;
From lstein at dev.open-bio.org Thu Sep 4 15:18:26 2008
From: lstein at dev.open-bio.org (Lincoln Stein)
Date: Thu, 4 Sep 2008 15:18:26 -0400
Subject: [Bioperl-guts-l] [14856]
bioperl-live/trunk/Bio/Graphics/Glyph/heat_map.pm: essential ideogram glyph
base class missing
Message-ID: <200809041918.m84JIQCd028165@dev.open-bio.org>
Revision: 14856
Author: lstein
Date: 2008-09-04 15:18:25 -0400 (Thu, 04 Sep 2008)
Log Message:
-----------
essential ideogram glyph base class missing
Added Paths:
-----------
bioperl-live/trunk/Bio/Graphics/Glyph/heat_map.pm
Added: bioperl-live/trunk/Bio/Graphics/Glyph/heat_map.pm
===================================================================
--- bioperl-live/trunk/Bio/Graphics/Glyph/heat_map.pm (rev 0)
+++ bioperl-live/trunk/Bio/Graphics/Glyph/heat_map.pm 2008-09-04 19:18:25 UTC (rev 14856)
@@ -0,0 +1,620 @@
+package Bio::Graphics::Glyph::heat_map;
+#$Id: heat_map.pm,v 1.4.2.3 2007/10/17 01:48:22 lstein Exp $
+
+use strict;
+use Bio::Graphics::Glyph::minmax;
+
+# A glyph to draw a heat map for scored features along a continuous color
+# gradient calculated in HSV color space
+
+use vars '@ISA';
+ at ISA = qw/Bio::Graphics::Glyph::minmax/;
+
+# set up getter/setter methods
+BEGIN {
+ no strict 'refs';
+
+ my @subs = qw/ h_start s_start v_start h_range s_range v_range
+ min_score max_score low_rgb low_hsv high_rgb score_range/;
+
+ for my $sub ( @subs ) {
+ *{$sub} = sub {
+ my ($self, $v) = @_;
+ my $k = "_$sub";
+
+ if (defined $v) {
+ $self->{$k} = $v;
+ }
+
+ return $self->{$k};
+ }
+ }
+}
+
+sub draw {
+ my $self = shift;
+
+ my @parts = $self->parts;
+ @parts = $self if !@parts && $self->level == 0;
+ return $self->SUPER::draw(@_) unless @parts;
+
+ $self->calculate_gradient(\@parts);
+ my $low_rgb = $self->low_rgb;
+
+ for my $part (@parts) {
+ my $score = $part->feature->score;
+
+ # use start color if no score or no score gradient
+ unless (defined $score && $self->score_range ) {
+ $part->{partcolor} = $self->color_index(@$low_rgb);
+ }
+ else {
+ my @rgb = $self->calculate_color($score);
+ $part->{partcolor} = $self->color_index(@rgb);
+ }
+
+ }
+
+ return $self->SUPER::draw(@_);
+}
+
+# We want an exact match, so allocate the color
+# if required
+sub color_index {
+ my ($self, @rgb) = @_;
+ my $gd = $self->panel->gd;
+ return $gd->colorResolve(@rgb);
+}
+
+# Override minmax method to get user supplied
+# values. This will be helpful for single or
+# unaggregated features.
+sub minmax {
+ my ($self, $parts) = @_;
+ my $min = $self->option('min_score');
+ my $max = $self->option('max_score');
+ return ($min,$max) if $min && $max && $min < $max;
+ return (0,$max) if $max && !$min; # minscore may be zero
+ return (0,100) unless $parts;
+ return $self->SUPER::minmax($parts);
+}
+
+# convert named color or hex string to RGB value, then HSV
+sub color2hsv {
+ my ($self,$color) = @_;
+ my $color_idx = $self->panel->translate_color($color);
+ my @rgb = $self->panel->rgb($color_idx);
+ return [$self->RGBtoHSV(@rgb)];
+}
+
+sub calculate_gradient {
+ my ($self, $parts) = @_;
+ my $start_color = lc $self->option('start_color') || 'white';
+ my $stop_color = lc $self->option('end_color') || 'red';
+ my $hsv_start = $self->color2hsv($start_color);
+ my $hsv_stop = $self->color2hsv($stop_color);
+
+ my ($h_start,$s_start,$v_start) = @$hsv_start;
+ my ($h_stop,$s_stop,$v_stop ) = @$hsv_stop;
+ my $h_range = $h_stop - $h_start;
+ my $s_range = $s_stop - $s_start;
+ my $v_range = $v_stop - $v_start;
+
+ # override brightness and saturation if required
+ if (my $bri = $self->option('brightness')) {
+ $bri = int($bri*255/100 + 0.5);
+ $v_start = $v_stop = $bri;
+ $v_range = 0;
+ }
+ if (my $sat = $self->option('saturation')) {
+ $sat = int($sat*255/100 + 0.5);
+ $s_start = $s_stop = $sat;
+ $s_range = 0;
+ }
+ if ($self->option('pure_hue')) {
+ $hsv_start = [$h_start,255,255];
+ $hsv_stop = [$h_stop,255,255];
+ $v_start = $v_stop = 255;
+ $s_start = $s_stop = 255;
+ $v_range = $s_range = 0;
+ }
+
+ # darkness or monochrome gradient?
+ if ( !_isa_color($start_color) || !_isa_color($stop_color) ) {
+ # hue (H) is fixed
+ $h_range = 0;
+
+ # gradient S V
+ # white -> color 0->255 255
+ # color -> white 255->0 255
+ # white -> black 0 255->0
+ # black -> white 0 0->255
+ # black -> color 0->255 0->255
+ # color -> black 255->0 255->0
+ if ( $start_color eq 'white' && _isa_color($stop_color) ) {
+ $s_range = 255;
+ $s_start = 0;
+ $v_range = 0;
+ $v_start = 255;
+ $h_start = $h_stop;
+ }
+ elsif ( _isa_color($start_color) && $stop_color eq 'white' ) {
+ $s_range = -255;
+ $s_start = 255;
+ $v_range = 0;
+ $v_start = 255;
+ }
+ elsif ( $start_color eq 'white' ) { # end black
+ $s_range = 0;
+ $s_start = 0;
+ $v_range = -255;
+ $v_start = 255;
+ }
+ elsif ( $stop_color eq 'white' ) { # start black
+ $s_range = 0;
+ $s_start = 0;
+ $v_range = 255;
+ $v_start = 0;
+ }
+ elsif ( _isa_color($start_color) ) { # end black
+ $s_range = 255;
+ $s_start = 0;
+ $v_range = 255;
+ $v_start = 0;
+ }
+ elsif ( _isa_color($stop_color) ) { # start black
+ $s_range = -255;
+ $s_start = 255;
+ $v_range = -255;
+ $v_start = 255;
+ }
+
+ }
+
+ # store gradient info
+ $self->h_range($h_range);
+ $self->h_start($h_start);
+ $self->s_start($s_start);
+ $self->v_start($v_start);
+ $self->s_range($s_range);
+ $self->v_range($v_range);
+
+ # store score info
+ my ($min,$max) = $self->minmax($parts);
+ $self->score_range($max - $min);
+ $self->min_score($min);
+ $self->max_score($max);
+
+ # store color extremes
+ my @low_rgb = $self->HSVtoRGB(@$hsv_start);
+ my @high_rgb = $self->HSVtoRGB(@$hsv_stop);
+ $self->low_hsv($hsv_start);
+ $self->high_rgb(\@high_rgb);
+ $self->low_rgb(\@low_rgb);
+ return 1;
+}
+
+sub _isa_color {
+ my $color = shift;
+ return $color =~ /white|black|FFFFFF|000000/i ? 0 : 1;
+}
+
+sub calculate_color {
+ my ($self,$score) = @_;
+ $score ||= 0;
+
+ # relative score
+ my $min = $self->min_score;
+ my $max = $self->max_score;
+ my $range = $self->score_range;
+
+ # reset off-scale scores
+ $score = $min if $score < $min;
+ $score = $max if $score > $max;
+ my $score_diff = ($score - $min)/$range;
+
+ # Hue
+ my $hue = $self->h_start;
+ my $h_diff = $score_diff * $self->h_range;
+ $hue += $h_diff;
+ $hue = int($hue+0.5);
+
+ # Saturation
+ my $sat = $self->s_start;
+ $sat += $score_diff * $self->s_range;
+ $sat = int($sat+0.5);
+
+ # Brightness
+ my $bri = $self->v_start;
+ $bri += $score_diff * $self->v_range;
+ $bri = int($bri + 0.5);
+
+ return $self->HSVtoRGB($hue,$sat,$bri);
+}
+
+# synthesize a key glyph
+sub keyglyph {
+ my $self = shift;
+ my $scale = 1/$self->scale; # base pairs/pixel
+ my $offset = $self->panel->offset;
+ my ($min,$max) = $self->minmax;
+ my $range = $max - $min;
+ my ($segments, $low);
+
+ for my $start (0..9) {
+ $start *= 10;
+ push @$segments, [ $start*$scale + $offset, ($start + 10)*$scale + $offset ];
+ }
+
+ my $feature = Bio::Graphics::Feature->new( -segments => $segments,
+ -name => $self->option('key'),
+ -strand => '+1' );
+
+ for (0..9) {
+ my $score += ($range/10) * $_;
+ ($feature->segments)[$_]->score($score);
+ }
+
+ my $factory = $self->factory->clone;
+ $factory->set_option(label => 1);
+ $factory->set_option(bump => 0);
+ $factory->set_option(min_score => 0);
+ $factory->set_option(max_score => 100);
+ return $factory->make_glyph(0,$feature);
+}
+
+sub bgcolor {
+ my $self = shift;
+ return defined $self->{partcolor} ? $self->{partcolor} : $self->SUPER::bgcolor;
+}
+sub fgcolor {
+ my $self = shift;
+ return $self->bgcolor;
+}
+
+sub RGBtoHSV {
+ my ($self, $r, $g ,$bl) = @_;
+ my ($min,undef,$max) = sort {$a<=>$b} ($r,$g,$bl);
+
+ my $range = $max - $min or return (0,0,$r);
+ my $v = $max;
+ my $s = 255 * ($max - $min)/$max;
+ my $h;
+
+ if ($max == $r) {
+ $h = 60 * ($g-$bl)/$range;
+ }
+ elsif ($max == $g) {
+ $h = 60 * ($bl-$r)/$range + 120;
+ }
+ else {
+ $h = 60 * ($r-$g)/$range + 240;
+ }
+
+ $h = int($h*255/360 + 0.5);
+ $h += 255 if $h < 0;
+ $h -= 255 if $h > 255;
+
+ return ($h, $s, $v);
+}
+
+# method courtesy of Lincoln Stein
+sub HSVtoRGB {
+ my $self = shift;
+ @_ == 3 or die "Usage: GD::Simple->HSVtoRGB(\$hue,\$saturation,\$value)";
+
+ my ($h,$s,$v)=@_;
+ my ($r,$g,$b,$i,$f,$p,$q,$t);
+
+ if( $s == 0 ) {
+ ## achromatic (grey)
+ return ($v,$v,$v);
+ }
+ $h %= 255;
+ $s /= 255; ## scale saturation from 0.0-1.0
+ $h /= 255; ## scale hue from 0 to 1.0
+ $h *= 360; ## and now scale it to 0 to 360
+
+ $h /= 60; ## sector 0 to 5
+ $i = $h % 6;
+ $f = $h - $i; ## factorial part of h
+ $p = $v * ( 1 - $s );
+ $q = $v * ( 1 - $s * $f );
+ $t = $v * ( 1 - $s * ( 1 - $f ) );
+
+ if($i<1) {
+ $r = $v;
+ $g = $t;
+ $b = $p;
+ } elsif($i<2){
+ $r = $q;
+ $g = $v;
+ $b = $p;
+ } elsif($i<3){
+ $r = $p;
+ $g = $v;
+ $b = $t;
+ } elsif($i<4){
+ $r = $p;
+ $g = $q;
+ $b = $v;
+ } elsif($i<5){
+ $r = $t;
+ $g = $p;
+ $b = $v;
+ } else {
+ $r = $v;
+ $g = $p;
+ $b = $q;
+ }
+ return (int($r+0.5),int($g+0.5),int($b+0.5));
+}
+
+
+1;
+
+=head1 NAME
+
+Bio::Graphics::Glyph::heat_map - The "heat_map" glyph
+
+=head1 SYNOPSIS
+
+See L and L.
+
+=head1 DESCRIPTION
+
+This glyph draws "scored" features using a continuous
+color gradient is the HSV color space. The color of
+each segment is proportionate to the score.
+
+=head1 OPTIONS
+
+=head2 Global glyph options:
+
+See L
+
+=head2 Glyph-specific options:
+
+The color_map glyph recognizes the following
+glyph-specific options:
+
+ Option Description Default
+ ------ ----------- -------
+
+ -start_color Beginning of the color white
+ gradient, expressed as a
+ named color or RGB hex
+ string
+
+ -end_color End of the color gradient red
+
+ -brightness Color brilliance: 0-100 Calculated
+ This will override the
+ value from the named
+ color
+
+ -saturation Color saturation: 0-100 Calculated
+ This will override the
+ value from the named
+ color
+
@@ Diff output truncated at 10000 characters. @@
From lstein at dev.open-bio.org Thu Sep 4 18:21:55 2008
From: lstein at dev.open-bio.org (Lincoln Stein)
Date: Thu, 4 Sep 2008 18:21:55 -0400
Subject: [Bioperl-guts-l] [14857] bioperl-live/trunk/Bio: fixed bugs that
interfered with the display of stranded features defined using the
FeatureFile format
Message-ID: <200809042221.m84MLti2028343@dev.open-bio.org>
Revision: 14857
Author: lstein
Date: 2008-09-04 18:21:55 -0400 (Thu, 04 Sep 2008)
Log Message:
-----------
fixed bugs that interfered with the display of stranded features defined using the FeatureFile format
Modified Paths:
--------------
bioperl-live/trunk/Bio/DB/SeqFeature/Store/FeatureFileLoader.pm
bioperl-live/trunk/Bio/Graphics/FeatureFile.pm
Modified: bioperl-live/trunk/Bio/DB/SeqFeature/Store/FeatureFileLoader.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/SeqFeature/Store/FeatureFileLoader.pm 2008-09-04 19:18:25 UTC (rev 14856)
+++ bioperl-live/trunk/Bio/DB/SeqFeature/Store/FeatureFileLoader.pm 2008-09-04 22:21:55 UTC (rev 14857)
@@ -463,7 +463,6 @@
$feature->add_SeqFeature($sp);
}
}
-
}
sub _multilevel_feature { # turn a single-level feature into a multilevel one
@@ -488,8 +487,12 @@
my $self = shift;
my ($name,$type,$strand,$attributes,$ref,$start,$end) = @_;
+ $strand ||= '';
+
my @args = (-name => $name,
- -strand => $strand||0,
+ -strand => $strand eq '+' ? 1
+ :$strand eq '-' ? -1
+ :0,
-attributes => $attributes,
);
@@ -642,6 +645,9 @@
sub parse_attributes {
my $self = shift;
my $att = shift;
+
+ $att ||= ''; # to prevent uninit variable warnings from quotewords()
+
my @pairs = quotewords('[;\s]',1,$att);
my %attributes;
for my $pair (@pairs) {
Modified: bioperl-live/trunk/Bio/Graphics/FeatureFile.pm
===================================================================
--- bioperl-live/trunk/Bio/Graphics/FeatureFile.pm 2008-09-04 19:18:25 UTC (rev 14856)
+++ bioperl-live/trunk/Bio/Graphics/FeatureFile.pm 2008-09-04 22:21:55 UTC (rev 14857)
@@ -632,12 +632,13 @@
}
eval "require $type"
unless $type->can('new');
- my $loader = $type->new(-store=>$db,
- -map_coords=>$self->{coordinate_mapper},
+ my $loader = $type->new(-store => $db,
+ -map_coords => $self->{coordinate_mapper},
-index_subfeatures => 0,
);
eval {$loader->allow_whitespace(1)}
if $self->allow_whitespace; # gff2 and gff3 loaders allow this
+
$loader->start_load() if $loader;
return $loader;
}
@@ -662,7 +663,7 @@
sub allow_whitespace {
my $self = shift;
my $d = $self->{allow_whitespace};
- $self->{allow_whitespace} = shift if $@;
+ $self->{allow_whitespace} = shift if @_;
$d;
}
From bugzilla-daemon at portal.open-bio.org Fri Sep 5 19:25:54 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Fri, 5 Sep 2008 19:25:54 -0400
Subject: [Bioperl-guts-l] [Bug 2579] New: Genbank parse gives wrong gene DNA
sequence for split genes
Message-ID:
http://bugzilla.open-bio.org/show_bug.cgi?id=2579
Summary: Genbank parse gives wrong gene DNA sequence for split
genes
Product: BioPerl
Version: 1.5 branch
Platform: PC
OS/Version: Windows
Status: NEW
Keywords: Bioperl
Severity: normal
Priority: P2
Component: Bio::SeqIO
AssignedTo: bioperl-guts-l at bioperl.org
ReportedBy: fossandon at vtr.net
Since many bacterial chromosomes and plasmids are circular, the people that
sequenced the DNA determines the starting point. This causes that sometimes a
gene is split in half by the defined starting point, and the problem is that
Bioperl (1.5.2_102) is not handling properly the sequence in this cases. This
happens more often that one would expect.
I tried following the modules to narrow the search for the faulty code but got
lost in the way, sorry. I'm not sure if this has been fixed in your SVN or not,
but please give it a look.
EXAMPLE:
Try to parse the following Genbank-formatted sequence I made, with the gene
coordinates "complement(join(993..1024,1..148))"; which in words would be
translated as "since is 993..1024 is the last part and 1..148 is
the first part, so gene starts in base 148, continues up to base 1, follows on
base 1024 (the last one) and continues up to base 993":
-------------------
LOCUS Test_GBK 1024 bp DNA circular 11-AUG-2008
DEFINITION Test split sequence.
ACCESSION
VERSION
KEYWORDS .
SOURCE Made up
ORGANISM Made up
Unclassified.
FEATURES Location/Qualifiers
source 1..1024
/organism="Made up"
/mol_type="genomic DNA"
gene complement(join(993..1024,1..148))
/locus_tag="Hypo_0001"
CDS complement(join(993..1024,1..148))
/locus_tag="Hypo_0001"
/codon_start=1
/transl_table=11
/product="Hypothetical protein"
/protein_id="Hypo_0001"
/translation="MDFEVELKSNKSNKVFYSWYKKNGFEHVGVKACFHNFVKEHKKQ
HMGGIRATWVNHNRN"
ORIGIN
1 gaattcctcc catatgctgt tttttatgct ctttcacaaa attgtgaaag caagctttaa
61 ccccaacatg ttcaaaacca tttttcttat accaagagta aaagacttta ttacttttat
121 ttgacttcaa ttcaacctca aaatccatca ctagagcatc cttctcagca tccgttagta
181 atgtaagata tttgtttatt ttatccttaa cgtatttttc atatctattt cttcgtcttt
241 cttccctttc tttctcagct tcttcttcta atttcctctt cattcgtgct tcactaataa
301 gcatctggct cgacttgctg gctttataat cttttcgtaa tgagtctatt aaatacccac
361 taaggccgcg tatcttccct tcttgaaaac tactggaatt tataatgatg ttcacttttt
421 cacgaatgaa cgctatatca tactctgtaa gcaaatctcg aataaaaagc ggagatagac
481 taaatgtatt tgttaaggtt tcttctaact ctgcattaat taggtttgag attttttcgg
541 atgacgcaag gtgtttttta ttcagtttaa atctaatctt tgtgactttt tggttttgtc
601 tctcgatttc tggtaagacc tgaatttgtg ataggttatt tacctcattc actgcaatat
661 tgagtactct ttttttaaaa tctttaaatg aagtgtattt accgcctaaa actcccatga
721 gttttctaaa aacatctaaa ggaaaccaag gtgtctgtga cagtctctgg tagcgaatac
781 agttttcata taatgctaaa ccatagcttg atttaaattt tgacatggtt tttacatcta
841 ttcttccata aatttccggc tggaaaagca attctttcat aatatgactg tactcataag
901 tacaaacgcc ttccgccagc tgagccgctg ataggattga acttgctttc caattttttt
961 ccttccctgt gccacaattg attagattcc attcaattgc ggttgtgatt aacccaagta
1021 gcgc
//
----------------------
Hypo_0001 sequence is in the complementary strand, its first part is on the
beginning of the whole sequence and its second part is on the end of the
sequence.
The whole Hypo_0001 real sequence in this case is 180 bases:
ATGGATTTTGAGGTTGAATTGAAGTCAAATAAAAGTAATAAAGTCTTTTACTCTTGGTAT
AAGAAAAATGGTTTTGAACATGTTGGGGTTAAAGCTTGCTTTCACAATTTTGTGAAAGAG
CATAAAAAACAGCATATGGGAGGAATTCGCGCTACTTGGGTTAATCACAACCGCAATTGA
The Hypo_0001 sequence give by Bioperl is 1024 bases!:
GAATTCCTCCCATATGCTGTTTTTTATGCTCTTTCACAAAATTGTGAAAGCAAGCTTTAA
CCCCAACATGTTCAAAACCATTTTTCTTATACCAAGAGTAAAAGACTTTATTACTTTTAT
TTGACTTCAATTCAACCTCAAAATCCATCACTAGAGCATCCTTCTCAGCATCCGTTAGTA
ATGTAAGATATTTGTTTATTTTATCCTTAACGTATTTTTCATATCTATTTCTTCGTCTTT
CTTCCCTTTCTTTCTCAGCTTCTTCTTCTAATTTCCTCTTCATTCGTGCTTCACTAATAA
GCATCTGGCTCGACTTGCTGGCTTTATAATCTTTTCGTAATGAGTCTATTAAATACCCAC
TAAGGCCGCGTATCTTCCCTTCTTGAAAACTACTGGAATTTATAATGATGTTCACTTTTT
CACGAATGAACGCTATATCATACTCTGTAAGCAAATCTCGAATAAAAAGCGGAGATAGAC
TAAATGTATTTGTTAAGGTTTCTTCTAACTCTGCATTAATTAGGTTTGAGATTTTTTCGG
ATGACGCAAGGTGTTTTTTATTCAGTTTAAATCTAATCTTTGTGACTTTTTGGTTTTGTC
TCTCGATTTCTGGTAAGACCTGAATTTGTGATAGGTTATTTACCTCATTCACTGCAATAT
TGAGTACTCTTTTTTTAAAATCTTTAAATGAAGTGTATTTACCGCCTAAAACTCCCATGA
GTTTTCTAAAAACATCTAAAGGAAACCAAGGTGTCTGTGACAGTCTCTGGTAGCGAATAC
AGTTTTCATATAATGCTAAACCATAGCTTGATTTAAATTTTGACATGGTTTTTACATCTA
TTCTTCCATAAATTTCCGGCTGGAAAAGCAATTCTTTCATAATATGACTGTACTCATAAG
TACAAACGCCTTCCGCCAGCTGAGCCGCTGATAGGATTGAACTTGCTTTCCAATTTTTTT
CCTTCCCTGTGCCACAATTGATTAGATTCCATTCAATTGCGGTTGTGATTAACCCAAGTA
GCGC
-------------------
So the results is that Bioperl not only used the first (1) and the last base
(1024) of the WHOLE sequence as Start and End (which are the reported values by
$feat->location->start/end), but also ignored the fact that the gene was on the
"complementary" strand and showed the forward sequence... if you translate it
manually the aminoacid sequence will also be wrong. In the end, this produces
genes of whole-genome length.
Besides, if you think carefully, the real Start and End for this proposed gene
are complement 148 and 993 respectively; by the way, how you can reproduce the
"complement(join(993..1024,1..148))" in an output file after passing through
bioperl???.
I looked around the code to see if I there was some simple solution I could
apply but got lost, so I'm posting here hoping that the real experts can find
the solution to the sequence and coordinates issues.
Sorry for posting the whole Genbank thing on the report, but I don't see any
button to attach files.
And thanks for your good work, Bioperl really helps me a lot!
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From heikki at dev.open-bio.org Sun Sep 7 01:32:37 2008
From: heikki at dev.open-bio.org (Heikki Lehvaslaiho)
Date: Sun, 7 Sep 2008 01:32:37 -0400
Subject: [Bioperl-guts-l] [14858] bioperl-live/trunk/Bio/Tree/Node.pm:
Document that get_tag_values() return variable is context sensitive (array
of scalar)
Message-ID: <200809070532.m875WbMh001942@dev.open-bio.org>
Revision: 14858
Author: heikki
Date: 2008-09-07 01:32:36 -0400 (Sun, 07 Sep 2008)
Log Message:
-----------
Document that get_tag_values() return variable is context sensitive (array of scalar)
Modified Paths:
--------------
bioperl-live/trunk/Bio/Tree/Node.pm
Modified: bioperl-live/trunk/Bio/Tree/Node.pm
===================================================================
--- bioperl-live/trunk/Bio/Tree/Node.pm 2008-09-04 22:21:55 UTC (rev 14857)
+++ bioperl-live/trunk/Bio/Tree/Node.pm 2008-09-07 05:32:36 UTC (rev 14858)
@@ -661,7 +661,9 @@
Title : get_tag_values
Usage : my @values = $node->get_tag_value($tag)
Function: Gets the values for given tag ($tag)
- Returns : Array of values or empty list if tag does not exist
+ Returns : In array context returns an array of values
+ or an empty list if tag does not exist.
+ In scalar context returns the first value or undef.
Args : $tag - tag name
=cut
From bugzilla-daemon at portal.open-bio.org Mon Sep 8 11:35:17 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 8 Sep 2008 11:35:17 -0400
Subject: [Bioperl-guts-l] [Bug 2580] New: enhancement for
Bio::SeqIO::interpro to include GO items when present
Message-ID:
http://bugzilla.open-bio.org/show_bug.cgi?id=2580
Summary: enhancement for Bio::SeqIO::interpro to include GO items
when present
Product: BioPerl
Version: main-trunk
Platform: Macintosh
OS/Version: MacOS X
Status: NEW
Severity: enhancement
Priority: P2
Component: Bio::SeqIO
AssignedTo: bioperl-guts-l at bioperl.org
ReportedBy: osborne6 at gmail.com
In working with some of the interpro xml parsing stuff thru Bio::SeqIO, I
noticed that the GO ids were not getting read into the seq features/annotation
collections. I've gone ahead and put together a patch for
Bio::SeqIO::interpro, patch for the interpro test case and an additional test
data file.
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Mon Sep 8 11:41:23 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 8 Sep 2008 11:41:23 -0400
Subject: [Bioperl-guts-l] [Bug 2580] enhancement for Bio::SeqIO::interpro to
include GO items when present
In-Reply-To:
Message-ID: <200809081541.m88FfNfd028509@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2580
------- Comment #1 from osborne6 at gmail.com 2008-09-08 11:41 EST -------
Created an attachment (id=991)
--> (http://bugzilla.open-bio.org/attachment.cgi?id=991&action=view)
diff/patch for Bio::SeqIO::interpro
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Mon Sep 8 11:41:58 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 8 Sep 2008 11:41:58 -0400
Subject: [Bioperl-guts-l] [Bug 2580] enhancement for Bio::SeqIO::interpro to
include GO items when present
In-Reply-To:
Message-ID: <200809081541.m88FfwRK028554@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2580
------- Comment #2 from osborne6 at gmail.com 2008-09-08 11:41 EST -------
Created an attachment (id=992)
--> (http://bugzilla.open-bio.org/attachment.cgi?id=992&action=view)
diff/patch to the interpro test cases
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Mon Sep 8 11:42:39 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Mon, 8 Sep 2008 11:42:39 -0400
Subject: [Bioperl-guts-l] [Bug 2580] enhancement for Bio::SeqIO::interpro to
include GO items when present
In-Reply-To:
Message-ID: <200809081542.m88Fgd8c028623@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2580
------- Comment #3 from osborne6 at gmail.com 2008-09-08 11:42 EST -------
Created an attachment (id=993)
--> (http://bugzilla.open-bio.org/attachment.cgi?id=993&action=view)
additional test file for interpro test case
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From fangly at dev.open-bio.org Mon Sep 8 13:32:31 2008
From: fangly at dev.open-bio.org (Florent E Angly)
Date: Mon, 8 Sep 2008 13:32:31 -0400
Subject: [Bioperl-guts-l] [14859] bioperl-live/trunk/Bio/Assembly/IO.pm:
Documentation improvement
Message-ID: <200809081732.m88HWVqp010063@dev.open-bio.org>
Revision: 14859
Author: fangly
Date: 2008-09-08 13:32:30 -0400 (Mon, 08 Sep 2008)
Log Message:
-----------
Documentation improvement
Modified Paths:
--------------
bioperl-live/trunk/Bio/Assembly/IO.pm
Modified: bioperl-live/trunk/Bio/Assembly/IO.pm
===================================================================
--- bioperl-live/trunk/Bio/Assembly/IO.pm 2008-09-07 05:32:36 UTC (rev 14858)
+++ bioperl-live/trunk/Bio/Assembly/IO.pm 2008-09-08 17:32:30 UTC (rev 14859)
@@ -29,8 +29,13 @@
while ( my $scaffold = $in->next_assembly() ) {
# do something with Bio::Assembly::Scaffold instance
+ # ...
+ $out->write_assembly(-scaffold => $scaffold);
}
+ $in->close;
+ $out->close;
+
=head1 DESCRIPTION
Bio::Assembly::IO is a handler module for formats in the Assembly::IO set
From fangly at dev.open-bio.org Mon Sep 8 13:34:23 2008
From: fangly at dev.open-bio.org (Florent E Angly)
Date: Mon, 8 Sep 2008 13:34:23 -0400
Subject: [Bioperl-guts-l] [14860] bioperl-live/trunk/Bio/Assembly/Contig.pm:
Update number of sequences and their order when removing a sequence from a
contig
Message-ID: <200809081734.m88HYNRG010179@dev.open-bio.org>
Revision: 14860
Author: fangly
Date: 2008-09-08 13:34:23 -0400 (Mon, 08 Sep 2008)
Log Message:
-----------
Update number of sequences and their order when removing a sequence from a contig
Modified Paths:
--------------
bioperl-live/trunk/Bio/Assembly/Contig.pm
Modified: bioperl-live/trunk/Bio/Assembly/Contig.pm
===================================================================
--- bioperl-live/trunk/Bio/Assembly/Contig.pm 2008-09-08 17:32:30 UTC (rev 14859)
+++ bioperl-live/trunk/Bio/Assembly/Contig.pm 2008-09-08 17:34:23 UTC (rev 14860)
@@ -1168,7 +1168,7 @@
Title : remove_seq
Usage : $contig->remove_seq($seq);
- Function : Removes a single sequence from an alignment
+ Function : Removes a single sequence from a contig
Returns : 1 on success, 0 otherwise
Argument : a Bio::LocatableSeq object
@@ -1190,10 +1190,31 @@
# Updating residue count
$self->{'_nof_residues'} -= $seq->length() +
&_nof_gaps( $self->{'_elem'}{$seqID}{'_gaps'}, $seq->length );
+
+ # Update number of sequences
+ $self->{'_nof_seqs'}--;
+
+ # Update order of sequences (order starts at 1)
+ my $max_order = $self->{'_nof_seqs'} + 1;
+ my $target_order = $max_order + 1;
+ for (my $order = 1 ; $order <= $max_order ; $order++) {
+ if ($self->{'_order'}->{$order} eq $seqID) {
+ # Found the wanted sequence order
+ $target_order = $order;
+ }
+ if ($order > $target_order) {
+ # Decrement this sequence order by one order
+ $self->{'_order'}->{$order-1} = $self->{'_order'}->{$order};
+ }
+ if ($order == $max_order) {
+ # Remove last order
+ delete $self->{'_order'}->{$order};
+ }
+ }
# Remove all references to features of this sequence
my @feats = ();
- foreach my $tag (keys %{ $self->{'_elem'}{$seqID}{'_feat'} }) {
+ for my $tag (keys %{ $self->{'_elem'}{$seqID}{'_feat'} }) {
push(@feats, $self->{'_elem'}{$seqID}{'_feat'}{$tag});
}
$self->{'_sfc'}->remove_features(\@feats);
From fangly at dev.open-bio.org Mon Sep 8 13:36:35 2008
From: fangly at dev.open-bio.org (Florent E Angly)
Date: Mon, 8 Sep 2008 13:36:35 -0400
Subject: [Bioperl-guts-l] [14861]
bioperl-live/trunk/Bio/Assembly/IO/tigr.pm: Bug correction regarding read
location in a contig
Message-ID: <200809081736.m88HaZxM010328@dev.open-bio.org>
Revision: 14861
Author: fangly
Date: 2008-09-08 13:36:35 -0400 (Mon, 08 Sep 2008)
Log Message:
-----------
Bug correction regarding read location in a contig
Modified Paths:
--------------
bioperl-live/trunk/Bio/Assembly/IO/tigr.pm
Modified: bioperl-live/trunk/Bio/Assembly/IO/tigr.pm
===================================================================
--- bioperl-live/trunk/Bio/Assembly/IO/tigr.pm 2008-09-08 17:34:23 UTC (rev 14860)
+++ bioperl-live/trunk/Bio/Assembly/IO/tigr.pm 2008-09-08 17:36:35 UTC (rev 14861)
@@ -90,7 +90,7 @@
type -> *
method -> always 'asmg' *
ed_status -> *
- redundancy -> percent of redundancy of the contig consensus
+ redundancy -> fold coverage of the contig consensus
perc_N -> percent of ambiguities in the contig consensus
seq# -> number of sequences in the contig
full_cds -> *
@@ -487,7 +487,7 @@
sub _store_read {
my ($self, $readinfo, $contigobj) = @_;
-
+
# Create an aligned read object
#$$readinfo{'llength'} = length($$readinfo{'lsequence'});
$$readinfo{'strand'} = ($$readinfo{'seq_rend'} > $$readinfo{'seq_lend'} ? 1 : -1);
@@ -502,10 +502,9 @@
-alphabet => 'dna'
);
- # Add read location and sequence to contig
- # (from 'ungapped consensus' to 'gapped consensus' coordinates)
- $$readinfo{'aln_start'} = $contigobj->change_coord('ungapped consensus', 'gapped consensus', $$readinfo{'asm_lend'});
- $$readinfo{'aln_end'} = $contigobj->change_coord('ungapped consensus', 'gapped consensus', $$readinfo{'asm_rend'});
+ # Add read location and sequence to contig (in 'gapped consensus' coordinates)
+ $$readinfo{'aln_start'} = $$readinfo{'offset'} + 1; # seq offset is in gapped coordinates
+ $$readinfo{'aln_end'} = $$readinfo{'aln_start'} + length($$readinfo{'lsequence'}) - 1; # lsequence is aligned seq
my $alncoord = Bio::SeqFeature::Generic->new(
-primary_tag => $readobj->id,
-start => $$readinfo{'aln_start'},
@@ -514,7 +513,7 @@
-tag => { 'contig' => $contigobj->id() }
);
$contigobj->set_seq_coord($alncoord, $readobj);
-
+
# Add quality clipping read information in contig features
# (from 'aligned read' to 'gapped consensus' coordinates)
$$readinfo{'clip_start'} = $contigobj->change_coord('aligned '.$readobj->id, 'gapped consensus', $$readinfo{'seq_lend'});
@@ -598,10 +597,10 @@
);
$singletobj->add_features([ $contigtags ], 1);
- # Add read location and sequence to singlet features
- # (from 'ungapped consensus' to 'gapped consensus' coordinates)
- $$readinfo{'aln_start'} = $$readinfo{'asm_lend'};
- $$readinfo{'aln_end'} = $$readinfo{'asm_rend'};
+ # Add read location and sequence to singlet features (in 'gapped consensus' coordinates)
+ $$readinfo{'aln_start'} = $$readinfo{'offset'} + 1; # seq offset is in gapped coordinates
+ $$readinfo{'aln_end'} = $$readinfo{'aln_start'} + length($$readinfo{'lsequence'}) - 1; # lsequence is aligned seq
+
my $alncoord = Bio::SeqFeature::Generic->new(
-primary_tag => "_aligned_coord:$readid",
-start => $$readinfo{'aln_start'},
@@ -893,7 +892,7 @@
my %readinfo;
$readinfo{'seq_name'} = $seq_name;
$readinfo{'asm_lend'} = $asm_lend;
- $readinfo{'asm_rend'} = $asm_rend;;
+ $readinfo{'asm_rend'} = $asm_rend;
$readinfo{'seq_lend'} = $seq_lend;
$readinfo{'seq_rend'} = $seq_rend;
$readinfo{'best'} = ($readanno->get_tag_values('best'))[0];
@@ -962,8 +961,8 @@
Title : _redundancy
Usage : my $ref = $ass_io->_redundancy($contigobj)
- Function: Calculate the redundancy of a contig consensus (average
- number of read base pairs covering the consensus)
+ Function: Calculate the fold coverage (redundancy) of a contig consensus
+ (average number of read base pairs covering the consensus)
Returns : decimal number
Args : Bio::Assembly::Contig
From cjfields at dev.open-bio.org Tue Sep 9 11:51:05 2008
From: cjfields at dev.open-bio.org (Christopher John Fields)
Date: Tue, 9 Sep 2008 11:51:05 -0400
Subject: [Bioperl-guts-l] [14862] bioperl-live/trunk: bug 2580
Message-ID: <200809091551.m89Fp5tY024757@dev.open-bio.org>
Revision: 14862
Author: cjfields
Date: 2008-09-09 11:51:03 -0400 (Tue, 09 Sep 2008)
Log Message:
-----------
bug 2580
* add GO ID parsing (patch courtesy of John Osborne)
Modified Paths:
--------------
bioperl-live/trunk/Bio/SeqIO/interpro.pm
bioperl-live/trunk/t/interpro.t
Added Paths:
-----------
bioperl-live/trunk/t/data/test.interpro-go.xml
Modified: bioperl-live/trunk/Bio/SeqIO/interpro.pm
===================================================================
--- bioperl-live/trunk/Bio/SeqIO/interpro.pm 2008-09-08 17:36:35 UTC (rev 14861)
+++ bioperl-live/trunk/Bio/SeqIO/interpro.pm 2008-09-09 15:51:03 UTC (rev 14862)
@@ -144,7 +144,8 @@
my $matlevel = join "", "/protein/interpro[", $interpn+1, "]/match[",
$match+1, "]/location";
my @locNodes = $protein_node->findnodes($matlevel);
-
+ my $class_level = join "", "/protein/interpro[",$interpn+1, "]/classification";
+ my @goNodes = $protein_node->findnodes($class_level);
my @seqFeatures = map { Bio::SeqFeature::Generic->new(
-start => $_->getAttribute('start'),
-end => $_->getAttribute('end'),
@@ -173,6 +174,16 @@
$annotation3->primary_id($DBNodes[$interpn]->getAttribute('id'));
$annotation3->comment($DBNodes[$interpn]->getAttribute('name'));
$seqFeature->annotation->add_Annotation('dblink',$annotation3);
+ # need to put in the go annotation here!
+ foreach my $g (@goNodes)
+ {
+ my $goid = $g->getAttribute('id');
+ my $go_annotation = Bio::Annotation::DBLink->new;
+ $go_annotation->database('GO');
+ $go_annotation->primary_id($goid);
+ $go_annotation->comment($goid);
+ $seqFeature->annotation->add_Annotation('dblink', $go_annotation);
+ }
}
$bioSeq->add_SeqFeature(@seqFeatures);
}
Added: bioperl-live/trunk/t/data/test.interpro-go.xml
===================================================================
--- bioperl-live/trunk/t/data/test.interpro-go.xml (rev 0)
+++ bioperl-live/trunk/t/data/test.interpro-go.xml 2008-09-09 15:51:03 UTC (rev 14862)
@@ -0,0 +1,132 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Molecular Function
+ DNA binding
+
+
+
+
+
+
+
+
+
+
+ Molecular Function
+ protein binding
+
+
+ Molecular Function
+ zinc ion binding
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Molecular Function
+ zinc ion binding
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Property changes on: bioperl-live/trunk/t/data/test.interpro-go.xml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: bioperl-live/trunk/t/interpro.t
===================================================================
--- bioperl-live/trunk/t/interpro.t 2008-09-08 17:36:35 UTC (rev 14861)
+++ bioperl-live/trunk/t/interpro.t 2008-09-09 15:51:03 UTC (rev 14862)
@@ -7,7 +7,7 @@
use lib 't/lib';
use BioperlTest;
- test_begin(-tests => 17,
+ test_begin(-tests => 19,
-requires_module => 'XML::DOM::XPath');
use_ok('Bio::SeqIO');
@@ -53,3 +53,15 @@
is (scalar @dblinks,3);
is $dblinks[1]->primary_id,'IPR009366';
is $dblinks[2]->primary_id,'PF06257.1';
+
+my $other_t_file = test_input_file('test.interpro-go.xml');
+my $ipr_in = Bio::SeqIO->new( -file => $other_t_file,
+ -verbose => $verbose,
+ -format => 'interpro');
+
+$seq = $ipr_in->next_seq();
+ at features = $seq->get_SeqFeatures;
+ at dblinks = $features[0]->annotation->get_Annotations('dblink');
+is (scalar @dblinks, 4);
+is $dblinks[3]->primary_id,'GO:0003677';
+
From bugzilla-daemon at portal.open-bio.org Tue Sep 9 11:51:25 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Tue, 9 Sep 2008 11:51:25 -0400
Subject: [Bioperl-guts-l] [Bug 2580] enhancement for Bio::SeqIO::interpro to
include GO items when present
In-Reply-To:
Message-ID: <200809091551.m89FpP4u006581@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2580
cjfields at bioperl.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|NEW |RESOLVED
Resolution| |FIXED
------- Comment #4 from cjfields at bioperl.org 2008-09-09 11:51 EST -------
Patch committed. Thanks!
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From cjfields at dev.open-bio.org Tue Sep 9 12:23:19 2008
From: cjfields at dev.open-bio.org (Christopher John Fields)
Date: Tue, 9 Sep 2008 12:23:19 -0400
Subject: [Bioperl-guts-l] [14863] bioperl-live/trunk/Bio/SeqFeatureI.pm: bug
2579
Message-ID: <200809091623.m89GNJm4024812@dev.open-bio.org>
Revision: 14863
Author: cjfields
Date: 2008-09-09 12:23:19 -0400 (Tue, 09 Sep 2008)
Log Message:
-----------
bug 2579
* spliced_seq() shouldn't automatically sort circular sequences. My question: should it be sorting a 'join' at all?
Modified Paths:
--------------
bioperl-live/trunk/Bio/SeqFeatureI.pm
Modified: bioperl-live/trunk/Bio/SeqFeatureI.pm
===================================================================
--- bioperl-live/trunk/Bio/SeqFeatureI.pm 2008-09-09 15:51:03 UTC (rev 14862)
+++ bioperl-live/trunk/Bio/SeqFeatureI.pm 2008-09-09 16:23:19 UTC (rev 14863)
@@ -428,8 +428,9 @@
in a circular sequence where a gene span starts
before the end of the sequence and ends after the
sequence start. Example : join(15685..16260,1..207)
- -phase truncates the returned sequence based on the
- intron phase (0,1,2).
+ (default = if sequence is_circular(), 1, otherwise 0)
+ -phase truncates the returned sequence based on the
+ intron phase (0,1,2).
Returns : A L object
@@ -440,7 +441,12 @@
my @args = @_;
my ($db, $nosort, $phase) =
$self->_rearrange([qw(DB NOSORT PHASE)], @args);
-
+
+ # set no_sort based on the parent sequence status
+ if ($self->entire_seq->is_circular) {
+ $nosort = 1;
+ }
+
# (added 7/7/06 to allow use old API (with warnings)
my $old_api = (!(grep {$_ =~ /(?:nosort|db|phase)/} @args)) ? 1 : 0;
if (@args && $old_api) {
From bugzilla-daemon at portal.open-bio.org Tue Sep 9 12:24:40 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Tue, 9 Sep 2008 12:24:40 -0400
Subject: [Bioperl-guts-l] [Bug 2579] Genbank parse gives wrong gene DNA
sequence for split genes
In-Reply-To:
Message-ID: <200809091624.m89GOe3I009149@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2579
cjfields at bioperl.org changed:
What |Removed |Added
----------------------------------------------------------------------------
Status|NEW |RESOLVED
Resolution| |FIXED
------- Comment #1 from cjfields at bioperl.org 2008-09-09 12:24 EST -------
Attachments are added after initially filing the report (see the 'Create a New
Attachment' link above).
You must be calling $sf->seq to get this result. Realize that calling seq()
retrieves the sequence region for the feature (not the spliced sequence, which
is what you want when the location is split as in the example). To get that
you should call spliced_seq().
However, there is still what I consider to be a bug present which isn't DWIM'my
enough. When calling spliced_seq(), it doesn't automatically arrange the split
locations based on whether the sequence is circular:
>Test_GBK_spliced_feat
GCGCTACTTGGGTTAATCACAACCGCAATTGAATGGATTTTGAGGTTGAATTGAAGTCAA
ATAAAAGTAATAAAGTCTTTTACTCTTGGTATAAGAAAAATGGTTTTGAACATGTTGGGG
TTAAAGCTTGCTTTCACAATTTTGTGAAAGAGCATAAAAAACAGCATATGGGAGGAATTC
You can actually correct this by passing in the -nosort option, which prevents
the sequence locations from being automatically sorted. That always gives the
sequence based on the order in the split location:
>Test_GBK_spliced_feat
ATGGATTTTGAGGTTGAATTGAAGTCAAATAAAAGTAATAAAGTCTTTTACTCTTGGTAT
AAGAAAAATGGTTTTGAACATGTTGGGGTTAAAGCTTGCTTTCACAATTTTGTGAAAGAG
CATAAAAAACAGCATATGGGAGGAATTCGCGCTACTTGGGTTAATCACAACCGCAATTGA
I have committed a change which changes this based on the status of is_circular
in the parent sequence, which fixes the problem. I'm still hoping to clean up
some of the Location issues in the next release of BioPerl.
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Wed Sep 10 00:36:27 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Wed, 10 Sep 2008 00:36:27 -0400
Subject: [Bioperl-guts-l] [Bug 2581] New: HMMER parse error
Message-ID:
http://bugzilla.open-bio.org/show_bug.cgi?id=2581
Summary: HMMER parse error
Product: BioPerl
Version: 1.5 branch
Platform: PC
OS/Version: Linux
Status: NEW
Severity: normal
Priority: P2
Component: Bio::Search/Bio::SearchIO
AssignedTo: bioperl-guts-l at bioperl.org
ReportedBy: zheboyang at gmail.com
#!/usr/bin/perl -w
#TODO: Parse the HMMER report
use strict;
use Bio::SearchIO;
my $directory="./HMM/";
opendir(HMMDIR, $directory), or die "Can't open the directory!";
my @filelist=readdir(HMMDIR);
foreach my $filename(@filelist)
{
if ($filename !~/^\./)
{
my $infile="$directory"."$
filename";
my $outfile="$infile"."HMMParse";
my $in = new Bio::SearchIO(-format => 'hmmer',-file =>"$infile");
- Ignored:
while (my $result= $in->next_result )
{
# get a Bio::Search::Result::HMMERResult object
# get hits numbers
my $hitnumber=$result->num_hits;
if ($hitnumber != 0)
{
open(OUT, ">$outfile"), or die "can't open the output file!!!!";
while (my $hits= $result->next_hit )
{
my $value=$hits->significance;
if ($value <=0.01)
{
print OUT
$hits->name,"\t",$hits->description,"\t",$hits->significance,"\n";
}
}
close OUT;
}
}
}
}
closedir(HMMDIR);
##############################################################
When it run, you will see that:
-------------------- WARNING ---------------------
MSG: unrecognized line: +E +L i T eek+ e+ ++ +l++H
Y+ I+ +
---------------------------------------------------
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From bugzilla-daemon at portal.open-bio.org Wed Sep 10 01:50:32 2008
From: bugzilla-daemon at portal.open-bio.org (bugzilla-daemon at portal.open-bio.org)
Date: Wed, 10 Sep 2008 01:50:32 -0400
Subject: [Bioperl-guts-l] [Bug 2581] HMMER parse error
In-Reply-To:
Message-ID: <200809100550.m8A5oWmw019104@portal.open-bio.org>
http://bugzilla.open-bio.org/show_bug.cgi?id=2581
------- Comment #1 from jason at bioperl.org 2008-09-10 01:50 EST -------
please attach the offending HMMER report to this bugzilla report
--
Configure bugmail: http://bugzilla.open-bio.org/userprefs.cgi?tab=email
------- You are receiving this mail because: -------
You are the assignee for the bug, or are watching the assignee.
From lstein at dev.open-bio.org Wed Sep 10 18:30:21 2008
From: lstein at dev.open-bio.org (Lincoln Stein)
Date: Wed, 10 Sep 2008 18:30:21 -0400
Subject: [Bioperl-guts-l] [14864] bioperl-live/trunk/Bio/DB: fixed
primary_id method to return a more rational result
Message-ID: <200809102230.m8AMULL5027828@dev.open-bio.org>
Revision: 14864
Author: lstein
Date: 2008-09-10 18:30:20 -0400 (Wed, 10 Sep 2008)
Log Message:
-----------
fixed primary_id method to return a more rational result
Modified Paths:
--------------
bioperl-live/trunk/Bio/DB/GFF/Adaptor/memory.pm
bioperl-live/trunk/Bio/DB/GFF/Feature.pm
bioperl-live/trunk/Bio/DB/GFF.pm
Modified: bioperl-live/trunk/Bio/DB/GFF/Adaptor/memory.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/GFF/Adaptor/memory.pm 2008-09-09 16:23:19 UTC (rev 14863)
+++ bioperl-live/trunk/Bio/DB/GFF/Adaptor/memory.pm 2008-09-10 22:30:20 UTC (rev 14864)
@@ -176,7 +176,7 @@
my $self = shift;
my $idx = 0;
foreach my $arrayref (values %{$self->{tmp}}) {
- foreach (@$arrayref) {$_->{feature_id} = $idx++; }
+ foreach (@$arrayref) {$_->{primary_id} = $idx++; }
push @{$self->{data}},@$arrayref;
}
1;
@@ -659,7 +659,7 @@
# of found features and continue.
my $found_feature = $feature ;
- $found_feature->{feature_id} = $feature_id;
+ $found_feature->{primary_id} = $feature_id;
$found_feature->{group_id} = $feature_group_id;
push @found_features,$found_feature;
}
Modified: bioperl-live/trunk/Bio/DB/GFF/Feature.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/GFF/Feature.pm 2008-09-09 16:23:19 UTC (rev 14863)
+++ bioperl-live/trunk/Bio/DB/GFF/Feature.pm 2008-09-10 22:30:20 UTC (rev 14864)
@@ -525,7 +525,8 @@
=cut
-sub id { shift->{db_id} }
+sub id { shift->{db_id} }
+sub primary_id { shift->{db_id} }
=head2 group_id
Modified: bioperl-live/trunk/Bio/DB/GFF.pm
===================================================================
--- bioperl-live/trunk/Bio/DB/GFF.pm 2008-09-09 16:23:19 UTC (rev 14863)
+++ bioperl-live/trunk/Bio/DB/GFF.pm 2008-09-10 22:30:20 UTC (rev 14864)
@@ -2101,7 +2101,7 @@
Title : attributes
Usage : @attributes = $db->attributes($id,$name)
- Function: get the "attributres" on a particular feature
+ Function: get the "attributes" on a particular feature
Returns : an array of string
Args : feature ID
Status : public
From bosborne at dev.open-bio.org Thu Sep 11 11:29:58 2008
From: bosborne at dev.open-bio.org (Brian Osborne)
Date: Thu, 11 Sep 2008 11:29:58 -0400
Subject: [Bioperl-guts-l] [14865]
bioperl-network/trunk/Bio/Network/ProteinNet.pm: Minor edits
Message-ID: <200809111529.m8BFTwCm000673@dev.open-bio.org>
Revision: 14865
Author: bosborne
Date: 2008-09-11 11:29:57 -0400 (Thu, 11 Sep 2008)
Log Message:
-----------
Minor edits
Modified Paths:
--------------
bioperl-network/trunk/Bio/Network/ProteinNet.pm
Modified: bioperl-network/trunk/Bio/Network/ProteinNet.pm
===================================================================
--- bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-10 22:30:20 UTC (rev 14864)
+++ bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-11 15:29:57 UTC (rev 14865)
@@ -106,7 +106,7 @@
# Retrieve all interactions
my @interx = $graph->interactions;
- # Let's get interactions above a threshold confidence score.
+ # Get interactions above a threshold confidence score
for my $interx (@interx) {
if ($interx->weight > 0.6) {
print $interx->primary_id, "\t", $interx->weight, "\n";
@@ -153,12 +153,12 @@
=head1 DESCRIPTION
A ProteinNet is a representation of a protein interaction network.
-Its functionality comes from the L of Perl and from BioPerl,
+Its functionality comes from the L module of Perl and from BioPerl,
the nodes or vertices in the network are Sequence objects.
=head2 Nodes
-A node is one or more BioPerl sequence object, a L or
+A node is one or more BioPerl sequence objects, a L or
L object. Essentially the graph can use any objects
that implement L and L interfaces
since these objects hold useful identifiers. This is relevant since the
@@ -183,8 +183,9 @@
=head1 FOR DEVELOPERS
In this module, the nodes or vertexes are represented by L
-objects containing all possible database identifiers but no sequence, as
-parsed from the interaction files.
+objects containing database identifiers but usually
+without sequence, since the data is parsed from protein-protein
+interaction data.
Interactions should be L objects, which are
L implementing objects. At present Interactions only
@@ -197,7 +198,7 @@
=item _id_map
-Look-up hash ('_id_map') for finding a node by any of its ids. The keys
+Look-up hash ('_id_map') for finding a node using any of its ids. The keys
are standard identifiers (e.g. "GenBank:A12345") and the values are
memory addresses used by Graph (e.g. "Bio::Network::Node=HASH(0x1bc53e4)").
@@ -211,7 +212,7 @@
=back
The function of these hashes is either to facilitate fast lookups or
-cache data temporarily.
+to cache data.
=head1 API CHANGES
@@ -918,7 +919,6 @@
my @nodes = $self->SUPER::articulation_points;
wantarray ? @nodes : scalar @nodes;
}
-
=head2 is_articulation_point
From bosborne at dev.open-bio.org Thu Sep 11 13:00:46 2008
From: bosborne at dev.open-bio.org (Brian Osborne)
Date: Thu, 11 Sep 2008 13:00:46 -0400
Subject: [Bioperl-guts-l] [14866]
bioperl-network/trunk/Bio/Network/ProteinNet.pm: Add methods to get random
node or edge
Message-ID: <200809111700.m8BH0ktM000818@dev.open-bio.org>
Revision: 14866
Author: bosborne
Date: 2008-09-11 13:00:45 -0400 (Thu, 11 Sep 2008)
Log Message:
-----------
Add methods to get random node or edge
Modified Paths:
--------------
bioperl-network/trunk/Bio/Network/ProteinNet.pm
Modified: bioperl-network/trunk/Bio/Network/ProteinNet.pm
===================================================================
--- bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-11 15:29:57 UTC (rev 14865)
+++ bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-11 17:00:45 UTC (rev 14866)
@@ -845,6 +845,40 @@
$g;
}
+=head2 get_random_edge
+
+ Name : get_random_edge
+ Purpose : Alias to Graph::random_edge
+ Usage : $edge = $graph1->get_random_edge;
+ Arguments :
+ Returns : An Edge object
+ Notes :
+
+=cut
+
+sub get_random_edge {
+ my $self = shift;
+ my $e = $self->SUPER::random_edge;
+ $e;
+}
+
+=head2 get_random_node
+
+ Name : get_random_node
+ Purpose : Alias to Graph::random_vertex
+ Usage : $node = $graph1->get_random_node;
+ Arguments :
+ Returns : A Node object
+ Notes :
+
+=cut
+
+sub get_random_node {
+ my $self = shift;
+ my $n = $self->SUPER::random_vertex;
+ $n;
+}
+
=head2 is_forest
Name : is_forest
@@ -976,33 +1010,7 @@
return $self->has_vertex($node);
}
-=head2 nodes_by_id
- Name : nodes_by_id
- Purpose : Alias to get_nodes_by_id
- Notes : Deprecated
-
-=cut
-
-sub nodes_by_id {
- my $self = shift;
- my @ids = @_;
- return $self->get_nodes_by_id(@ids);
-}
-
-=head2 edge_count
-
- Name : edge_count
- Purpose : Alias to edges()
- Notes : Deprecated, use edges()
-
-=cut
-
-sub edge_count {
- my $self = shift;
- return scalar $self->edges;
-}
-
=head2 interactions
Name : interactions
@@ -1030,6 +1038,33 @@
}
}
+=head2 nodes_by_id
+
+ Name : nodes_by_id
+ Purpose : Alias to get_nodes_by_id
+ Notes : Deprecated
+
+=cut
+
+sub nodes_by_id {
+ my $self = shift;
+ my @ids = @_;
+ return $self->get_nodes_by_id(@ids);
+}
+
+=head2 edge_count
+
+ Name : edge_count
+ Purpose : Alias to edges()
+ Notes : Deprecated, use edges()
+
+=cut
+
+sub edge_count {
+ my $self = shift;
+ return scalar $self->edges;
+}
+
=head2 neighbor_count
Name : neighbor_count
From bosborne at dev.open-bio.org Fri Sep 12 12:36:46 2008
From: bosborne at dev.open-bio.org (Brian Osborne)
Date: Fri, 12 Sep 2008 12:36:46 -0400
Subject: [Bioperl-guts-l] [14867] bioperl-network/trunk: Add get_random* and
tests
Message-ID: <200809121636.m8CGak2D002815@dev.open-bio.org>
Revision: 14867
Author: bosborne
Date: 2008-09-12 12:36:45 -0400 (Fri, 12 Sep 2008)
Log Message:
-----------
Add get_random* and tests
Modified Paths:
--------------
bioperl-network/trunk/Bio/Network/ProteinNet.pm
bioperl-network/trunk/t/ProteinNet.t
Modified: bioperl-network/trunk/Bio/Network/ProteinNet.pm
===================================================================
--- bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-11 17:00:45 UTC (rev 14866)
+++ bioperl-network/trunk/Bio/Network/ProteinNet.pm 2008-09-12 16:36:45 UTC (rev 14867)
@@ -858,7 +858,7 @@
sub get_random_edge {
my $self = shift;
- my $e = $self->SUPER::random_edge;
+ my $e = $self->random_edge;
$e;
}
@@ -875,7 +875,7 @@
sub get_random_node {
my $self = shift;
- my $n = $self->SUPER::random_vertex;
+ my $n = $self->random_vertex;
$n;
}
Modified: bioperl-network/trunk/t/ProteinNet.t
===================================================================
--- bioperl-network/trunk/t/ProteinNet.t 2008-09-11 17:00:45 UTC (rev 14866)
+++ bioperl-network/trunk/t/ProteinNet.t 2008-09-12 16:36:45 UTC (rev 14867)
@@ -7,24 +7,27 @@
$DEBUG = $ENV{'BIOPERLDEBUG'} || 0;
BEGIN {
- # to handle systems with no installed Test module
- # we include the t dir (where a copy of Test.pm is located)
- # as a fallback
- eval { require Test; };
- $ERROR = 0;
+ # to handle systems with no installed Test modules
+ # we include the t/lib directory just in case
+ $ERROR = 0;
+
+ eval { require Test };
if ( $@ ) {
- use lib 't';
+ use lib 't/lib';
}
+
use Test;
- $NUMTESTS = 168;
+
+ $NUMTESTS = 170;
plan tests => $NUMTESTS;
+
eval { require Graph; };
- if ($@) {
+ if ( $@ ) {
warn "Perl's Graph needed for the bioperl-network package, skipping tests";
$ERROR = 1;
}
eval { require XML::Twig; };
- if ($@) {
+ if ( $@ ) {
warn "XML::Twig needed for XML format parsing, skipping tests";
$ERROR = 1;
}
@@ -36,11 +39,10 @@
}
}
-exit 0 if $ERROR == 1;
+exit(0) if $ERROR == 1;
require Bio::Network::ProteinNet;
require Bio::Network::IO;
-require Bio::Network::Interaction;
my $verbose = 0;
$verbose = 1 if $DEBUG;
@@ -66,7 +68,7 @@
my $x = 0;
my @ids = qw(A64696 2314583 3053N);
for my $k (keys %ids) {
- ok $ids{$k},$ids[$x++];
+ ok ( $ids{$k},$ids[$x++] );
}
#
# test deleting nodes
@@ -279,6 +281,13 @@
#
@components = $g1->components;
ok scalar @components, 3;
+#
+# random
+#
+$n = $g1->get_random_node;
+ok( ref($n), 'Bio::Network::Node');
+my $e = $g1->get_random_edge;
+ok( ref($e->[0]), 'Bio::Network::Node');
__END__
From bosborne at dev.open-bio.org Fri Sep 12 16:00:57 2008
From: bosborne at dev.open-bio.org (Brian Osborne)
Date: Fri, 12 Sep 2008 16:00:57 -0400
Subject: [Bioperl-guts-l] [14868] bioperl-network/trunk:
Message-ID: <200809122000.m8CK0v0h002999@dev.open-bio.org>
Revision: 14868
Author: bosborne
Date: 2008-09-12 16:00:57 -0400 (Fri, 12 Sep 2008)
Log Message:
-----------
Modified Paths:
--------------
bioperl-network/trunk/Bio/Network/IO/psi10.pm
bioperl-network/trunk/Bio/Network/IO/psi25.pm
Added Paths:
-----------
bioperl-network/trunk/t/Test.pm
Modified: bioperl-network/trunk/Bio/Network/IO/psi10.pm
===================================================================
--- bioperl-network/trunk/Bio/Network/IO/psi10.pm 2008-09-12 16:36:45 UTC (rev 14867)
+++ bioperl-network/trunk/Bio/Network/IO/psi10.pm 2008-09-12 20:00:57 UTC (rev 14868)
@@ -244,12 +244,12 @@
use Bio::Network::Node;
use Bio::Species;
use Bio::Annotation::DBLink;
-use Bio::Annotation::OntologyTerm;
use Bio::Annotation::Collection;
-use Bio::Annotation::Comment;
-use Bio::Annotation::Reference;
-use Bio::Annotation::SimpleValue;
-use Bio::Network::IO::psi::intact;
+# use Bio::Annotation::OntologyTerm;
+# use Bio::Annotation::Comment;
+# use Bio::Annotation::Reference;
+# use Bio::Annotation::SimpleValue;
+# use Bio::Network::IO::psi::intact;
use vars qw( @ISA %species $net $fac );
@ISA = qw(Bio::Network::IO Bio::Root::Root );
Modified: bioperl-network/trunk/Bio/Network/IO/psi25.pm
===================================================================
--- bioperl-network/trunk/Bio/Network/IO/psi25.pm 2008-09-12 16:36:45 UTC (rev 14867)
+++ bioperl-network/trunk/Bio/Network/IO/psi25.pm 2008-09-12 20:00:57 UTC (rev 14868)
@@ -28,14 +28,14 @@
The following databases provide their data as PSI MI XML:
-BIND L
DIP L
HPRD L
IntAct L
MINT L
Each of these databases will call PSI format by some different name.
-for example, PSI MI from DIP comes in files with the suffix "mif".
+for example, PSI MI from DIP comes in files with the suffix "mif"
+whereas PSI MI from IntAct or MINT has the "xml" suffix.
Documentation for PSI XML can be found at L.
Added: bioperl-network/trunk/t/Test.pm
===================================================================
--- bioperl-network/trunk/t/Test.pm (rev 0)
+++ bioperl-network/trunk/t/Test.pm 2008-09-12 20:00:57 UTC (rev 14868)
@@ -0,0 +1,253 @@
+use strict;
+package Test;
+use Carp;
+use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
+ qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
+$VERSION = '1.15';
+require Exporter;
+ at ISA=('Exporter');
+ at EXPORT=qw(&plan &ok &skip);
+ at EXPORT_OK=qw($ntest $TESTOUT);
+
+$TestLevel = 0; # how many extra stack frames to skip
+$|=1;
+#$^W=1; ?
+$ntest=1;
+$TESTOUT = *STDOUT{IO};
+
+# Use of this variable is strongly discouraged. It is set mainly to
+# help test coverage analyzers know which test is running.
+$ENV{REGRESSION_TEST} = $0;
+
+sub plan {
+ croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+ croak "Test::plan(): should not be called more than once" if $planned;
+ my $max=0;
+ for (my $x=0; $x < @_; $x+=2) {
+ my ($k,$v) = @_[$x,$x+1];
+ if ($k =~ /^test(s)?$/) { $max = $v; }
+ elsif ($k eq 'todo' or
+ $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+ elsif ($k eq 'onfail') {
+ ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
+ $ONFAIL = $v;
+ }
+ else { carp "Test::plan(): skipping unrecognized directive '$k'" }
+ }
+ my @todo = sort { $a <=> $b } keys %todo;
+ if (@todo) {
+ print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
+ } else {
+ print $TESTOUT "1..$max\n";
+ }
+ ++$planned;
+}
+
+sub to_value {
+ my ($v) = @_;
+ (ref $v or '') eq 'CODE' ? $v->() : $v;
+}
+
+sub ok ($;$$) {
+ croak "ok: plan before you test!" if !$planned;
+ my ($pkg,$file,$line) = caller($TestLevel);
+ my $repetition = ++$history{"$file:$line"};
+ my $context = ("$file at line $line".
+ ($repetition > 1 ? " fail \#$repetition" : ''));
+ my $ok=0;
+ my $result = to_value(shift);
+ my ($expected,$diag);
+ if (@_ == 0) {
+ $ok = $result;
+ } else {
+ $expected = to_value(shift);
+ my ($regex,$ignore);
+ if (!defined $expected) {
+ $ok = !defined $result;
+ } elsif (!defined $result) {
+ $ok = 0;
+ } elsif ((ref($expected)||'') eq 'Regexp') {
+ $ok = $result =~ /$expected/;
+ } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
+ $ok = $result =~ /$regex/;
+ } else {
+ $ok = $result eq $expected;
+ }
+ }
+ my $todo = $todo{$ntest};
+ if ($todo and $ok) {
+ $context .= ' TODO?!' if $todo;
+ print $TESTOUT "ok $ntest # ($context)\n";
+ } else {
+ print $TESTOUT "not " if !$ok;
+ print $TESTOUT "ok $ntest\n";
+
+ if (!$ok) {
+ my $detail = { 'repetition' => $repetition, 'package' => $pkg,
+ 'result' => $result, 'todo' => $todo };
+ $$detail{expected} = $expected if defined $expected;
+ $diag = $$detail{diagnostic} = to_value(shift) if @_;
+ $context .= ' *TODO*' if $todo;
+ if (!defined $expected) {
+ if (!$diag) {
+ print $TESTOUT "# Failed test $ntest in $context\n";
+ } else {
+ print $TESTOUT "# Failed test $ntest in $context: $diag\n";
+ }
+ } else {
+ my $prefix = "Test $ntest";
+ print $TESTOUT "# $prefix got: ".
+ (defined $result? "'$result'":'')." ($context)\n";
+ $prefix = ' ' x (length($prefix) - 5);
+ if ((ref($expected)||'') eq 'Regexp') {
+ $expected = 'qr/'.$expected.'/'
+ } else {
+ $expected = "'$expected'";
+ }
+ if (!$diag) {
+ print $TESTOUT "# $prefix Expected: $expected\n";
+ } else {
+ print $TESTOUT "# $prefix Expected: $expected ($diag)\n";
+ }
+ }
+ push @FAILDETAIL, $detail;
+ }
+ }
+ ++ $ntest;
+ $ok;
+}
+
+sub skip ($$;$$) {
+ my $whyskip = to_value(shift);
+ if ($whyskip) {
+ $whyskip = 'skip' if $whyskip =~ m/^\d+$/;
+ print $TESTOUT "ok $ntest # $whyskip\n";
+ ++ $ntest;
+ 1;
+ } else {
+ local($TestLevel) = $TestLevel+1; #ignore this stack frame
+ &ok;
+ }
+}
+
+END {
+ $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+ Test - provides a simple framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use strict;
+ use Test;
+
+ # use a BEGIN block so we print our plan before MyModule is loaded
+ BEGIN { plan tests => 14, todo => [3,4] }
+
+ # load your module...
+ use MyModule;
+
+ ok(0); # failure
+ ok(1); # success
+
+ ok(0); # ok, expected failure (see todo list, above)
+ ok(1); # surprise success!
+
+ ok(0,1); # failure: '0' ne '1'
+ ok('broke','fixed'); # failure: 'broke' ne 'fixed'
+ ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+ ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
+
+ ok(sub { 1+1 }, 2); # success: '2' eq '2'
+ ok(sub { 1+1 }, 3); # failure: '2' ne '3'
+ ok(0, int(rand(2)); # (just kidding :-)
+
+ my @list = (0,0);
+ ok @list, 3, "\@list=".join(',', at list); #extra diagnostics
+ ok 'segmentation fault', '/(?i)success/'; #regex match
+
+ skip($feature_is_missing, ...); #do platform specific test
+
+=head1 DESCRIPTION
+
+L expects to see particular output when it
+executes tests. This module aims to make writing proper test scripts just
+a little bit easier (and less error prone :-).
+
+=head1 TEST TYPES
+
+=over 4
+
+=item * NORMAL TESTS
+
+These tests are expected to succeed. If they don't something's
+screwed up!
+
+=item * SKIPPED TESTS
+
+Skip is for tests that might or might not be possible to run depending
+on the availability of platform specific features. The first argument
+should evaluate to true (think "yes, please skip") if the required
+feature is not available. After the first argument, skip works
+exactly the same way as do normal tests.
+
+=item * TODO TESTS
+
+TODO tests are designed for maintaining an B.
+These tests are expected NOT to succeed. If a TODO test does succeed,
+the feature in question should not be on the TODO list, now should it?
+
+Packages should NOT be released with succeeding TODO tests. As soon
+as a TODO test starts working, it should be promoted to a normal test
+and the newly working feature should be documented in the release
+notes or change log.
+
+=back
+
+=head1 RETURN VALUE
+
+Both C and C return true if their test succeeds and false
+otherwise in a scalar context.
+
+=head1 ONFAIL
+
+ BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
+
+While test failures should be enough, extra diagnostics can be
+triggered at the end of a test run. C is passed an array ref
+of hash refs that describe each test failure. Each hash will contain
+at least the following fields: C, C, and
+C. (The file, line, and test number are not included because
+their correspondence to a particular test is tenuous.) If the test
+had an expected value or a diagnostic string, these will also be
+included.
+
+The B C hook might be used simply to print out the
+version of your package and/or how to report problems. It might also
+be used to generate extremely sophisticated diagnostics for a
+particularly bizarre test failure. However it's not a panacea. Core
+dumps or other unrecoverable errors prevent the C hook from
+running. (It is run inside an C block.) Besides, C is
+probably over-kill in most cases. (Your test code should be simpler
+than the code it is testing, yes?)
+
+=head1 SEE ALSO
+
+L and, perhaps, test coverage analysis tools.
+
+=head1 AUTHOR
+
+Copyright (c) 1998-1999 Joshua Nathaniel Pritikin. All rights reserved.
+
+This package is free software and is provided "as is" without express
+or implied warranty. It may be used, redistributed and/or modified
+under the terms of the Perl Artistic License (see
+http://www.perl.com/perl/misc/Artistic.html)
+
+=cut
From heikki at dev.open-bio.org Sat Sep 13 15:10:32 2008
From: heikki at dev.open-bio.org (Heikki Lehvaslaiho)
Date: Sat, 13 Sep 2008 15:10:32 -0400
Subject: [Bioperl-guts-l] [14869] bioperl-live/trunk/Bio/Tree/Node.pm: Start
counting internal IDs from 1.
Message-ID: <200809131910.m8DJAWYQ004879@dev.open-bio.org>
Revision: 14869
Author: heikki
Date: 2008-09-13 15:10:30 -0400 (Sat, 13 Sep 2008)
Log Message:
-----------
Start counting internal IDs from 1. 0 as an index was creating too much trouble.
Should not make any difference at code usage.
Modified Paths:
--------------
bioperl-live/trunk/Bio/Tree/Node.pm
Modified: bioperl-live/trunk/Bio/Tree/Node.pm
===================================================================
--- bioperl-live/trunk/Bio/Tree/Node.pm 2008-09-12 20:00:57 UTC (rev 14868)
+++ bioperl-live/trunk/Bio/Tree/Node.pm 2008-09-13 19:10:30 UTC (rev 14869)
@@ -77,8 +77,8 @@
use base qw(Bio::Root::Root Bio::Tree::NodeI);
-BEGIN {
- $CREATIONORDER = 0;
+BEGIN {
+ $CREATIONORDER = 1;
}
=head2 new
From cjfields at dev.open-bio.org Sun Sep 14 15:23:06 2008
From: cjfields at dev.open-bio.org (Christopher John Fields)
Date: Sun, 14 Sep 2008 15:23:06 -0400
Subject: [Bioperl-guts-l] [14870]
bioperl-live/trunk/Bio/SeqIO/entrezgene.pm: use direct object syntax
Message-ID: <200809141923.m8EJN6oo010670@dev.open-bio.org>
Revision: 14870
Author: cjfields
Date: 2008-09-14 15:23:05 -0400 (Sun, 14 Sep 2008)
Log Message:
-----------
use direct object syntax
Modified Paths:
--------------
bioperl-live/trunk/Bio/SeqIO/entrezgene.pm
Modified: bioperl-live/trunk/Bio/SeqIO/entrezgene.pm
===================================================================
--- bioperl-live/trunk/Bio/SeqIO/entrezgene.pm 2008-09-13 19:10:30 UTC (rev 14869)
+++ bioperl-live/trunk/Bio/SeqIO/entrezgene.pm 2008-09-14 19:23:05 UTC (rev 14870)
@@ -168,7 +168,7 @@
$xval=$value->[0];
#return unless ($xval->{gene}->{desc} eq 'albumin');
#return new Bio::Seq (-id=>'Generif service record', -seq=>'') unless ($xval->{'track-info'}{geneid}== 283);
- return new Bio::Seq (-id=>'Generif service record', -seq=>'') if (($self->{_service_record} ne 'yes')&&
+ return Bio::Seq->new(-id=>'Generif service record', -seq=>'') if (($self->{_service_record} ne 'yes')&&
($xval->{gene}->{desc} =~ /record to support submission of generifs for a gene not in entrez/i));
#Basic data
#$xval->{summary}=~s/\n//g;
From cjfields at dev.open-bio.org Sun Sep 14 15:23:46 2008
From: cjfields at dev.open-bio.org (Christopher John Fields)
Date: Sun, 14 Sep 2008 15:23:46 -0400
Subject: [Bioperl-guts-l] [14871]
bioperl-live/trunk/Bio/Tools/Run/RemoteBlast.pm: add a few new ( untested)
URLAPI parameters
Message-ID: <200809141923.m8EJNkvQ010698@dev.open-bio.org>
Revision: 14871
Author: cjfields
Date: 2008-09-14 15:23:46 -0400 (Sun, 14 Sep 2008)
Log Message:
-----------
add a few new (untested) URLAPI parameters
Modified Paths:
--------------
bioperl-live/trunk/Bio/Tools/Run/RemoteBlast.pm
Modified: bioperl-live/trunk/Bio/Tools/Run/RemoteBlast.pm
===================================================================
--- bioperl-live/trunk/Bio/Tools/Run/RemoteBlast.pm 2008-09-14 19:23:05 UTC (rev 14870)
+++ bioperl-live/trunk/Bio/Tools/Run/RemoteBlast.pm 2008-09-14 19:23:46 UTC (rev 14871)
@@ -203,6 +203,7 @@
'(Pairwise|(Flat)?QueryAnchored(NoIdentities)?|Tabular)',
# Pairwise, QueryAnchored, QueryAnchoredNoIdentities,
# FlatQueryAnchored, FlatQueryAnchoredNoIdentities, Tabular
+ 'DATABASE_SORT' => '\d',
'DESCRIPTIONS' => '\d+', # Positive integer
'ENTREZ_LINKS_NEW_WINDOW' => '(yes|no)', # yes, no
'EXPECT_LOW' => '\d+(\.\d+)?([eE]-\d+)?', # Positive double
@@ -215,6 +216,7 @@
'FORMAT_TYPE' => '((HT|X)ML|ASN\.1|Text)',
# HTML, Text, ASN.1, XML
'NCBI_GI' => '(yes|no)', # yes, no
+ 'NEW_VIEW' => '(true|false)',
'RID' => '.*',
'RESULTS_FILE' => '(yes|no)', # yes, no
'SERVICE' => '(plain|p[sh]i|(rps|mega)blast)',
From cjfields at dev.open-bio.org Sun Sep 14 16:41:42 2008
From: cjfields at dev.open-bio.org (Christopher John Fields)
Date: Sun, 14 Sep 2008 16:41:42 -0400
Subject: [Bioperl-guts-l] [14872]
bioperl-live/trunk/Bio/Annotation/TagTree.pm: Create Data:: Stag node
lazily; always use node() to grab node instance
Message-ID: <200809142041.m8EKfgZm010906@dev.open-bio.org>
Revision: 14872
Author: cjfields
Date: 2008-09-14 16:41:42 -0400 (Sun, 14 Sep 2008)
Log Message:
-----------
Create Data::Stag node lazily; always use node() to grab node instance
Modified Paths:
--------------
bioperl-live/trunk/Bio/Annotation/TagTree.pm
Modified: bioperl-live/trunk/Bio/Annotation/TagTree.pm
===================================================================
--- bioperl-live/trunk/Bio/Annotation/TagTree.pm 2008-09-14 19:23:46 UTC (rev 14871)
+++ bioperl-live/trunk/Bio/Annotation/TagTree.pm 2008-09-14 20:41:42 UTC (rev 14872)
@@ -125,23 +125,29 @@
=cut
-sub new{
- my ($class, at args) = @_;
- my $self = $class->SUPER::new();
- my ($node, $value,$tag, $format, $verbose) = $self->_rearrange([qw(
- NODE
- VALUE
- TAGNAME
- TAGFORMAT
- VERBOSE)], @args);
- $self->throw("Cant use both node and value; mutually exclusive") if defined $node && defined $value;
- defined $tag && $self->tagname($tag);
- $format ||= 'itext';
- $self->tagformat($format);
- defined $value ? $self->value($value) : $self->node(Data::Stag->new());
- defined $node && $self->node($node);
- defined $verbose && $self->verbose($verbose);
- return $self;
+sub new {
+ my ( $class, @args ) = @_;
+ my $self = $class->SUPER::new();
+ my ( $node, $value, $tag, $format, $verbose ) = $self->_rearrange(
+ [
+ qw(
+ NODE
+ VALUE
+ TAGNAME
+ TAGFORMAT
+ VERBOSE)
+ ],
+ @args
+ );
+ $self->throw("Cant use both node and value; mutually exclusive")
+ if defined $node && defined $value;
+ defined $tag && $self->tagname($tag);
+ $format ||= 'itext';
+ $self->tagformat($format);
+ defined $value && $self->value($value);
+ defined $node && $self->node($node);
+ defined $verbose && $self->verbose($verbose);
+ return $self;
}
=head1 AnnotationI implementing functions
@@ -158,9 +164,9 @@
=cut
-sub as_text{
- my ($self) = @_;
- return "TagTree: ".$self->value;
+sub as_text {
+ my ($self) = @_;
+ return "TagTree: " . $self->value;
}
=head2 display_text
@@ -180,14 +186,14 @@
=cut
{
- my $DEFAULT_CB = sub { $_[0]->value || ''};
+ my $DEFAULT_CB = sub { $_[0]->value || '' };
- sub display_text {
- my ($self, $cb) = @_;
- $cb ||= $DEFAULT_CB;
- $self->throw("Callback must be a code reference") if ref $cb ne 'CODE';
- return $cb->($self);
- }
+ sub display_text {
+ my ( $self, $cb ) = @_;
+ $cb ||= $DEFAULT_CB;
+ $self->throw("Callback must be a code reference") if ref $cb ne 'CODE';
+ return $cb->($self);
+ }
}
@@ -203,10 +209,10 @@
=cut
-sub hash_tree{
- my ($self) = @_;
- my $h = {};
- $h->{'value'} = $self->value;
+sub hash_tree {
+ my ($self) = @_;
+ my $h = {};
+ $h->{'value'} = $self->value;
}
=head2 tagname
@@ -223,12 +229,12 @@
=cut
-sub tagname{
- my ($self,$value) = @_;
- if( defined $value) {
- $self->{'tagname'} = $value;
- }
- return $self->{'tagname'};
+sub tagname {
+ my ( $self, $value ) = @_;
+ if ( defined $value ) {
+ $self->{'tagname'} = $value;
+ }
+ return $self->{'tagname'};
}
=head1 Specific accessors for TagTree
@@ -245,32 +251,39 @@
=cut
-sub value{
- my ($self,$value) = @_;
- # set mode? This resets the entire tagged database
- my $format = $self->tagformat;
- if ($value) {
- if (ref $value) {
- if (ref $value eq 'ARRAY') {
- # note the tagname() is not used here; it is only used for
- # storing this AnnotationI in the annotation collection
- eval { $self->{db} = Data::Stag->nodify($value) };
- } else {
- # assuming this is blessed; passing on to node() and copy
- $self->node($value, 'copy');
- }
- } else {
- # not trying to guess here for now; we go by the tagformat() setting
- my $h = Data::Stag->getformathandler($format);
- eval {$self->{db} = Data::Stag->from($format.'str',$value)};
- }
- $self->throw("Data::Stag error:\n$@") if $@;
- }
- # get mode?
- # How do we return a data structure?
- # for now, we use the output (if there is a Data::Stag node present)
- # may need to an an eval {} to catch Data::Stag output errors
- $self->{db}->$format;
+sub value {
+ my ( $self, $value ) = @_;
+
+ # set mode? This resets the entire tagged database
+ my $format = $self->tagformat;
+ if ($value) {
+ if ( ref $value ) {
+ if ( ref $value eq 'ARRAY' ) {
+
+ # note the tagname() is not used here; it is only used for
+ # storing this AnnotationI in the annotation collection
+ eval { $self->{db} = Data::Stag->nodify($value) };
+ }
+ else {
+
+ # assuming this is blessed; passing on to node() and copy
+ $self->node( $value, 'copy' );
+ }
+ }
+ else {
+
+ # not trying to guess here for now; we go by the tagformat() setting
+ my $h = Data::Stag->getformathandler($format);
+ eval { $self->{db} = Data::Stag->from( $format . 'str', $value ) };
+ }
+ $self->throw("Data::Stag error:\n$@") if $@;
+ }
+
+ # get mode?
+ # How do we return a data structure?
+ # for now, we use the output (if there is a Data::Stag node present)
+ # may need to an an eval {} to catch Data::Stag output errors
+ $self->node->$format;
}
=head2 tagformat
@@ -284,17 +297,17 @@
=cut
-my %IS_VALID_FORMAT = map {$_ => 1} qw(xml indent sxpr itext);
+my %IS_VALID_FORMAT = map { $_ => 1 } qw(xml indent sxpr itext);
-sub tagformat{
- my ($self,$value) = @_;
- if( defined $value) {
- $self->throw("$value is not a valid format; valid format types:\n".
- join(',',map {"'$_'"} keys %IS_VALID_FORMAT))
- if !exists $IS_VALID_FORMAT{$value};
- $self->{'tagformat'} = $value;
- }
- return $self->{'tagformat'};
+sub tagformat {
+ my ( $self, $value ) = @_;
+ if ( defined $value ) {
+ $self->throw( "$value is not a valid format; valid format types:\n"
+ . join( ',', map { "'$_'" } keys %IS_VALID_FORMAT ) )
+ if !exists $IS_VALID_FORMAT{$value};
+ $self->{'tagformat'} = $value;
+ }
+ return $self->{'tagformat'};
}
=head2 node
@@ -309,19 +322,23 @@
=cut
-sub node{
- my ($self,$value, $copy) = @_;
- if( defined $value && ref $value) {
- $self->{'db'} = $value->isa('Data::Stag::StagI') ?
- ($copy && $copy eq 'copy' ? $value->duplicate : $value) :
- $value->isa('Bio::Annotation::TagTree') ?
- ($copy && $copy eq 'copy' ? $value->node->duplicate : $value->node) :
- $self->throw('Object must be Data::Stag::StagI or Bio::Annotation::TagTree');
- #$self->{'db'} = $value->isa('Data::Stag::StagI') ? $value :
- # $value->isa('Bio::Annotation::TagTree') ? $value->node :
- # $self->throw('Object must be Data::Stag::StagI or Bio::Annotation::TagTree');
- }
- return $self->{'db'};
+sub node {
+ my ( $self, $value, $copy ) = @_;
+ if ( defined $value && ref $value ) {
+ $self->{'db'} =
+ $value->isa('Data::Stag::StagI')
+ ? ( $copy && $copy eq 'copy' ? $value->duplicate : $value )
+ : $value->isa('Bio::Annotation::TagTree') ? ( $copy
+ && $copy eq 'copy' ? $value->node->duplicate : $value->node )
+ : $self->throw(
+ 'Object must be Data::Stag::StagI or Bio::Annotation::TagTree');
+ }
+
+ # lazily create Data::Stag instance if not present
+ if (!$self->{'db'}) {
+ $self->{'db'} = Data::Stag->new();
+ }
+ return $self->{'db'};
}
=head2 Data::Stag convenience methods
@@ -348,8 +365,8 @@
=cut
sub element {
- my $self = shift;
- return $self->{db}->element;
+ my $self = shift;
+ return $self->node->element;
}
=head2 data
@@ -364,8 +381,8 @@
=cut
sub data {
- my $self = shift;
- return $self->{db}->dat